src/RTL/RTLToERTL.ml

   1
   2 (** This module provides a translation of [RTL] programs to [ERTL]
   3     programs. *)
   4
   5
   6 let error_prefix = "RTL to ERTL"
   7 let error = Error.global_error error_prefix
   8
   9
  10 (* Helper functions *)
  11
  12 let change_exit_label lbl def =
  13   { def with ERTL.f_exit = lbl }
  14
  15 let add_graph lbl stmt def =
  16   { def with ERTL.f_graph = Label.Map.add lbl stmt def.ERTL.f_graph }
  17
  18 let fresh_label def = Label.Gen.fresh def.ERTL.f_luniverse
  19
  20 let change_label lbl = function
  21   | ERTL.St_skip _ -> ERTL.St_skip lbl
  22   | ERTL.St_comment (s, _) -> ERTL.St_comment (s, lbl)
  23   | ERTL.St_cost (cost_lbl, _) -> ERTL.St_cost (cost_lbl, lbl)
  24   | ERTL.St_get_hdw (r1, r2, _) -> ERTL.St_get_hdw (r1, r2, lbl)
  25   | ERTL.St_set_hdw (r1, r2, _) -> ERTL.St_set_hdw (r1, r2, lbl)
  26   | ERTL.St_hdw_to_hdw (r1, r2, _) -> ERTL.St_hdw_to_hdw (r1, r2, lbl)
  27   | ERTL.St_newframe _ -> ERTL.St_newframe lbl
  28   | ERTL.St_delframe _ -> ERTL.St_delframe lbl
  29   | ERTL.St_framesize (r, _) -> ERTL.St_framesize (r, lbl)
  30   | ERTL.St_pop (r, _) -> ERTL.St_pop (r, lbl)
  31   | ERTL.St_push (r, _) -> ERTL.St_push (r, lbl)
  32   | ERTL.St_addrH (r, id, _) -> ERTL.St_addrH (r, id, lbl)
  33   | ERTL.St_addrL (r, id, _) -> ERTL.St_addrL (r, id, lbl)
  34   | ERTL.St_int (r, i, _) -> ERTL.St_int (r, i, lbl)
  35   | ERTL.St_move (r1, r2, _) -> ERTL.St_move (r1, r2, lbl)
  36   | ERTL.St_opaccsA (opaccs, dstr, srcr1, srcr2, _) ->
  37     ERTL.St_opaccsA (opaccs, dstr, srcr1, srcr2, lbl)
  38   | ERTL.St_opaccsB (opaccs, dstr, srcr1, srcr2, _) ->
  39     ERTL.St_opaccsB (opaccs, dstr, srcr1, srcr2, lbl)
  40   | ERTL.St_op1 (op1, dstr, srcr, _) -> ERTL.St_op1 (op1, dstr, srcr, lbl)
  41   | ERTL.St_op2 (op2, dstr, srcr1, srcr2, _) ->
  42     ERTL.St_op2 (op2, dstr, srcr1, srcr2, lbl)
  43   | ERTL.St_clear_carry _ -> ERTL.St_clear_carry lbl
  44   | ERTL.St_set_carry _ -> ERTL.St_set_carry lbl
  45   | ERTL.St_load (dstrs, addr1, addr2, _) ->
  46     ERTL.St_load (dstrs, addr1, addr2, lbl)
  47   | ERTL.St_store (addr1, addr2, srcrs, _) ->
  48     ERTL.St_store (addr1, addr2, srcrs, lbl)
  49   | ERTL.St_call_id (f, nb_args, _) -> ERTL.St_call_id (f, nb_args, lbl)
  50   | ERTL.St_call_ptr (f1, f2, nb_args, _) ->
  51     ERTL.St_call_ptr (f1, f2, nb_args, lbl)
  52   | ERTL.St_cond _ as inst -> inst
  53   | ERTL.St_return _ as inst -> inst
  54
  55 (* Process a list of function that adds a list of instructions to a graph, from
  56    one label to another, and by creating fresh labels inbetween. *)
  57
  58 let rec add_translates translate_list start_lbl dest_lbl def =
  59   match translate_list with
  60     | [] -> add_graph start_lbl (ERTL.St_skip dest_lbl) def
  61     | [trans] -> trans start_lbl dest_lbl def
  62     | trans :: translate_list ->
  63       let tmp_lbl = fresh_label def in
  64       let def = trans start_lbl tmp_lbl def in
  65       add_translates translate_list tmp_lbl dest_lbl def
  66
  67 (* Add a sequence of instruction in a graph, from one label to another, by creating
  68    fresh labels inbetween. *)
  69
  70 (* FIXME: Clean this up by factorizing with the previous function. *)
  71 let rec adds_graph stmt_list start_lbl dest_lbl def =
  72   match stmt_list with
  73     | [] -> add_graph start_lbl (ERTL.St_skip dest_lbl) def
  74     | [stmt] ->
  75       add_graph start_lbl (change_label dest_lbl stmt) def
  76     | stmt :: stmt_list ->
  77       let tmp_lbl = fresh_label def in
  78       let stmt = change_label tmp_lbl stmt in
  79       let def = add_graph start_lbl stmt def in
  80       adds_graph stmt_list tmp_lbl dest_lbl def
  81
  82 let fresh_reg def =
  83   let r = Register.fresh def.ERTL.f_runiverse in
  84   let locals = Register.Set.add r def.ERTL.f_locals in
  85   ({ def with ERTL.f_locals = locals }, r)
  86
  87 let rec fresh_regs def n =
  88   if n = 0 then (def, [])
  89   else
  90     let (def, res) = fresh_regs def (n-1) in
  91     let (def, r) = fresh_reg def in
  92     (def, r :: res)
  93
  94
  95 (* Translation *)
  96
  97 let save_hdws l =
  98   let f (destr, srcr) start_lbl =
  99     adds_graph [ERTL.St_get_hdw (destr, srcr, start_lbl)] start_lbl in
 100   List.map f l
 101
 102 let restore_hdws l =
 103   let f (destr, srcr) start_lbl =
 104     adds_graph [ERTL.St_set_hdw (destr, srcr, start_lbl)] start_lbl in
 105   List.map f (List.map (fun (x, y) -> (y, x)) l)
 106
 107 let get_params_hdw params =
 108   if List.length params = 0 then
 109     [fun start_lbl -> adds_graph [ERTL.St_skip start_lbl] start_lbl]
 110   else
 111     let l = MiscPottier.combine params I8051.parameters in
 112     save_hdws l
 113
 114 let get_param_stack off destr start_lbl dest_lbl def =
 115   let (def, addr1) = fresh_reg def in
 116   let (def, addr2) = fresh_reg def in
 117   let (def, tmpr) = fresh_reg def in
 118   adds_graph
 119     [ERTL.St_framesize (addr1, start_lbl) ;
 120      ERTL.St_int (tmpr, off+I8051.int_size, start_lbl) ;
 121      ERTL.St_op2 (I8051.Sub, addr1, addr1, tmpr, start_lbl) ;
 122      ERTL.St_get_hdw (tmpr, I8051.spl, start_lbl) ;
 123      ERTL.St_op2 (I8051.Add, addr1, addr1, tmpr, start_lbl) ;
 124      ERTL.St_int (addr2, 0, start_lbl) ;
 125      ERTL.St_get_hdw (tmpr, I8051.sph, start_lbl) ;
 126      ERTL.St_op2 (I8051.Addc, addr2, addr2, tmpr, start_lbl) ;
 127      ERTL.St_load (destr, addr1, addr2, start_lbl)]
 128     start_lbl dest_lbl def
 129
 130 let get_params_stack params =
 131   if List.length params = 0 then
 132     [fun start_lbl -> adds_graph [ERTL.St_skip start_lbl] start_lbl]
 133   else
 134     let f i r = get_param_stack i r in
 135     MiscPottier.mapi f params
 136
 137 (* Parameters are taken from the physical parameter registers first. If there
 138    are not enough such of these, then the remaining parameters are taken from
 139    the stack. *)
 140
 141 let get_params params =
 142   let n = min (List.length params) (List.length I8051.parameters) in
 143   let (hdw_params, stack_params) = MiscPottier.split params n in
 144   (get_params_hdw hdw_params) @ (get_params_stack stack_params)
 145
 146 let add_prologue params sral srah sregs def =
 147   let start_lbl = def.ERTL.f_entry in
 148   let tmp_lbl = fresh_label def in
 149   let last_stmt = Label.Map.find start_lbl def.ERTL.f_graph in
 150   let def =
 151     add_translates
 152       ([adds_graph [ERTL.St_comment ("Prologue", start_lbl)]] @
 153        (* new frame *)
 154        (adds_graph [ERTL.St_comment ("New frame", start_lbl) ;
 155                     ERTL.St_newframe start_lbl]) ::
 156        (* save the return address *)
 157        (adds_graph [ERTL.St_comment ("Save return address", start_lbl) ;
 158                     ERTL.St_pop (sral, start_lbl) ;
 159                     ERTL.St_pop (srah, start_lbl)]) ::
 160        (* save callee-saved registers *)
 161        [adds_graph [ERTL.St_comment ("Save callee-saved registers",
 162                                      start_lbl)]] @
 163        (save_hdws sregs) @
 164        (* fetch parameters *)
 165        [adds_graph [ERTL.St_comment ("Fetch parameters", start_lbl)]] @
 166        (get_params params) @
 167        [adds_graph [ERTL.St_comment ("End Prologue", start_lbl)]])
 168       start_lbl tmp_lbl def in
 169   add_graph tmp_lbl last_stmt def
 170
 171
 172 (* Save the result of a function in a place that cannot be written, even after
 173    register allocation. This way, the cleaning sequence of returning from a
 174    function will not interfere with the result value, that can be restored right
 175    before jumping out of the function. *)
 176
 177 (* L'existence de cette fonction résulte du choix d'utiliser DPTR à la fois
 178    pour effectuer l'arithmétique de pointeur sur la pile et le retour des
 179    fonctions. On aurait probablement pu faire un autre choix. *)
 180 let save_return ret_regs start_lbl dest_lbl def =
 181   let (def, tmpr) = fresh_reg def in
 182   (* Sépare les registres utiles pour le stockage effectif des valeurs
 183      des registres de retour de ceux qui ne seront pas utilisés, et
 184      donc mis à zéro. *)
 185   let ((common1, rest1), (common2, rest2)) =
 186     (* I8051.sts are registers that are reserved in order to store the
 187        result of functions. *)
 188     MiscPottier.reduce I8051.sts ret_regs
 189   in
 190   assert (rest2 = []); (* parce qu'on suppose que la valeur de retour
 191                           tient dans l'ensemble des registres réservés
 192                           pour la stocker. *)
 193
 194   (* Met a zero les registres utilisés pour le retour car la valeur
 195      de retour pourrait être plus petite que la capacité totale de
 196      stockage des registres physiques de retour conventionnels. *)
 197
 198   (* FIXME: Nicolas pense qu'en vérité cette mise à zéro ne sert à
 199      rien car plus tard (cf. FIXME plus loin dans la fonction
 200      fetch_result), ces registres à zéro ne seront pas considérés. *)
 201   let init_tmpr = ERTL.St_int (tmpr, 0, start_lbl) in
 202
 203   (* Sauvegarde temporairement la valeur des registres de retour
 204      dans des registres frais car ces registres de retour peuvent
 205      être utilisés pour faire de l'arithmétique de pointeurs sur
 206      le pointeur de pile lors du dépilement. *)
 207   let f_save st r = ERTL.St_set_hdw (st, r, start_lbl) in
 208   let saves = List.map2 f_save common1 common2 in
 209   (* Le reste est mis à zéro.  *)
 210   let f_default st = ERTL.St_set_hdw (st, tmpr, start_lbl) in
 211   let defaults = List.map f_default rest1 in
 212   adds_graph (init_tmpr :: saves @ defaults) start_lbl dest_lbl def
 213
 214 (* Après avoir travaillé sur la pile, on sait que l'on peut sans danger
 215    copier le contenu sauvegardé dans les registres temporaires vers
 216    les registres de retour. *)
 217 let assign_result start_lbl =
 218   let ((common1, rest1), (common2, rest2)) = MiscPottier.reduce I8051.rets I8051.sts in
 219   assert (rest1 = [] && rest2 = []);
 220   (* parce qu'on suppose que |I8051.rets| = |I8051.sts|. *)
 221   let f ret st = ERTL.St_hdw_to_hdw (ret, st, start_lbl) in
 222   let insts = List.map2 f common1 common2 in
 223   adds_graph insts start_lbl
 224
 225 let add_epilogue ret_regs sral srah sregs def =
 226   let start_lbl = def.ERTL.f_exit in
 227   let tmp_lbl = fresh_label def in
 228   let last_stmt = Label.Map.find start_lbl def.ERTL.f_graph in
 229   let def =
 230     add_translates
 231       ([adds_graph [ERTL.St_comment ("Epilogue", start_lbl)]] @
 232        (* save return value *)
 233        [save_return ret_regs] @
 234        (* restore callee-saved registers *)
 235        [adds_graph [ERTL.St_comment ("Restore callee-saved registers",
 236                                      start_lbl)]] @
 237        (restore_hdws sregs) @
 238        (* restore the return address *)
 239        [adds_graph [ERTL.St_comment ("Restore return address", start_lbl) ;
 240                     ERTL.St_push (srah, start_lbl) ;
 241                     ERTL.St_push (sral, start_lbl)]] @
 242        (* delete frame *)
 243        [adds_graph [ERTL.St_comment ("Delete frame", start_lbl) ;
 244                     ERTL.St_delframe start_lbl]] @
 245        (* assign the result to actual return registers *)
 246        [adds_graph [ERTL.St_comment ("Set result", start_lbl)]] @
 247        [assign_result] @
 248        [adds_graph [ERTL.St_comment ("End Epilogue", start_lbl)]])
 249       start_lbl tmp_lbl def in
 250   let def = add_graph tmp_lbl last_stmt def in
 251   change_exit_label tmp_lbl def
 252
 253
 254 let allocate_regs saved def =
 255   let f r (def, sregs) =
 256     let (def, r') = fresh_reg def in
 257     (def, (r', r) :: sregs) in
 258   I8051.RegisterSet.fold f saved (def, [])
 259
 260 let add_pro_and_epilogue params ret_regs def =
 261   (* Allocate registers to hold the return address. *)
 262   let (def, sra) = fresh_regs def 2 in
 263   let sral = List.nth sra 0 in
 264   let srah = List.nth sra 1 in
 265   (* Allocate registers to save callee-saved registers. *)
 266   let (def, sregs) = allocate_regs I8051.callee_saved def in
 267   (* Add a prologue and a epilogue. *)
 268   let def = add_prologue params sral srah sregs def in
 269   let def = add_epilogue ret_regs sral srah sregs def in
 270   def
 271
 272
 273 let set_params_hdw params =
 274   if List.length params = 0 then
 275     [fun start_lbl -> adds_graph [ERTL.St_skip start_lbl] start_lbl]
 276   else
 277     let l = MiscPottier.combine params I8051.parameters in
 278     restore_hdws l
 279
 280 let set_param_stack off srcr start_lbl dest_lbl def =
 281   let (def, addr1) = fresh_reg def in
 282   let (def, addr2) = fresh_reg def in
 283   let (def, tmpr) = fresh_reg def in
 284   adds_graph
 285     [ERTL.St_int (addr1, off+I8051.int_size, start_lbl) ;
 286      ERTL.St_get_hdw (tmpr, I8051.spl, start_lbl) ;
 287      ERTL.St_clear_carry start_lbl ;
 288      ERTL.St_op2 (I8051.Sub, addr1, tmpr, addr1, start_lbl) ;
 289      ERTL.St_get_hdw (tmpr, I8051.sph, start_lbl) ;
 290      ERTL.St_int (addr2, 0, start_lbl) ;
 291      ERTL.St_op2 (I8051.Sub, addr2, tmpr, addr2, start_lbl) ;
 292      ERTL.St_store (addr1, addr2, srcr, start_lbl)]
 293     start_lbl dest_lbl def
 294
 295 let set_params_stack params =
 296   if List.length params = 0 then
 297     [fun start_lbl -> adds_graph [ERTL.St_skip start_lbl] start_lbl]
 298   else
 299     let f i r = set_param_stack i r in
 300     MiscPottier.mapi f params
 301
 302 (* Parameters are put in the physical parameter registers first. If there are
 303    not enough such of these, then the remaining parameters are passed on the
 304    stack. *)
 305
 306 let set_params params =
 307   let n = min (List.length params) (List.length I8051.parameters) in
 308   let (hdw_params, stack_params) = MiscPottier.split params n in
 309   (set_params_hdw hdw_params) @ (set_params_stack stack_params)
 310
 311 (* Fetching the result depends on the type of the function, or say, the number
 312    of registers that are waiting for a value. Temporary non allocatable
 313    registers are used. Indeed, moving directly from DPL to a pseudo-register may
 314    cause a bug: DPL might be used to compute the address of the
 315    pseudo-register. *)
 316
 317 let fetch_result ret_regs start_lbl =
 318   let ((common1, rest1), (common2, rest2)) = MiscPottier.reduce I8051.sts I8051.rets in
 319   assert (rest1 = [] && rest2 = []);
 320   let f_save st ret = ERTL.St_hdw_to_hdw (st, ret, start_lbl) in
 321   let saves = List.map2 f_save common1 common2 in
 322   let ((common1, rest1), (common2, rest2)) = MiscPottier.reduce ret_regs I8051.sts in
 323   (* FIXME: [rest2] est ignoré mais ce n'est pas grave car ils ne
 324      contiennent pas des données significatives. Du coup, il n'était
 325      probablement pas nécessaire de les mettre à zéro. *)
 326   let f_restore r st = ERTL.St_get_hdw (r, st, start_lbl) in
 327   let restores = List.map2 f_restore common1 common2 in
 328   adds_graph (saves @ restores) start_lbl
 329
 330 (* When calling a function, we need to set its parameters in specific locations:
 331    the physical parameter registers as much as possible, and then the stack
 332    below. When the called function returns, we put the result where the calling
 333    function expect it to be. *)
 334 let translate_call stmt args ret_regs start_lbl dest_lbl def =
 335   let nb_args = List.length args in
 336   add_translates
 337     ([adds_graph [ERTL.St_comment ("Starting a call", start_lbl)] ;
 338       adds_graph [ERTL.St_comment ("Setting up parameters", start_lbl)]] @
 339      set_params args @
 340      [adds_graph [stmt nb_args] ;
 341       adds_graph [ERTL.St_comment ("Fetching result", start_lbl)] ;
 342       fetch_result ret_regs ;
 343       adds_graph [ERTL.St_comment ("End of call sequence", start_lbl)]])
 344     start_lbl dest_lbl def
 345
 346 let translate_stmt lbl stmt def = match stmt with
 347   | RTL.St_skip lbl' ->
 348     add_graph lbl (ERTL.St_skip lbl') def
 349
 350   | RTL.St_cost (cost_lbl, lbl') ->
 351     add_graph lbl (ERTL.St_cost (cost_lbl, lbl')) def
 352
 353   | RTL.St_addr (r1, r2, x, lbl') ->
 354     adds_graph
 355       [ERTL.St_addrL (r1, x, lbl) ; ERTL.St_addrH (r2, x, lbl) ;]
 356       lbl lbl' def
 357
 358   | RTL.St_stackaddr (r1, r2, lbl') ->
 359     adds_graph
 360       [ERTL.St_get_hdw (r1, I8051.spl, lbl) ;
 361        ERTL.St_get_hdw (r2, I8051.sph, lbl)]
 362       lbl lbl' def
 363
 364   | RTL.St_int (r, i, lbl') ->
 365     add_graph lbl (ERTL.St_int (r, i, lbl')) def
 366
 367   | RTL.St_move (r1, r2, lbl') ->
 368     add_graph lbl (ERTL.St_move (r1, r2, lbl')) def
 369
 370   | RTL.St_opaccs (op, destr1, destr2, srcr1, srcr2, lbl') ->
 371     adds_graph [ERTL.St_opaccsA (op, destr1, srcr1, srcr2, lbl) ;
 372                 ERTL.St_opaccsB (op, destr2, srcr1, srcr2, lbl) ;]
 373       lbl lbl' def
 374
 375   | RTL.St_op1 (op1, destr, srcr, lbl') ->
 376     add_graph lbl (ERTL.St_op1 (op1, destr, srcr, lbl')) def
 377
 378   | RTL.St_op2 (op2, destr, srcr1, srcr2, lbl') ->
 379     add_graph lbl (ERTL.St_op2 (op2, destr, srcr1, srcr2, lbl')) def
 380
 381   | RTL.St_clear_carry lbl' ->
 382     add_graph lbl (ERTL.St_clear_carry lbl') def
 383
 384   | RTL.St_set_carry lbl' ->
 385     add_graph lbl (ERTL.St_set_carry lbl') def
 386
 387   | RTL.St_load (destr, addr1, addr2, lbl') ->
 388     add_graph lbl (ERTL.St_load (destr, addr1, addr2, lbl')) def
 389
 390   | RTL.St_store (addr1, addr2, srcr, lbl') ->
 391     add_graph lbl (ERTL.St_store (addr1, addr2, srcr, lbl')) def
 392
 393   | RTL.St_call_id (f, args, ret_regs, lbl') ->
 394     let stmt nb_args = ERTL.St_call_id (f, nb_args, lbl) in
 395     translate_call stmt args ret_regs lbl lbl' def
 396
 397   | RTL.St_call_ptr (f1, f2, args, ret_regs, lbl') ->
 398     let stmt nb_args = ERTL.St_call_ptr (f1, f2, nb_args, lbl) in
 399     translate_call stmt args ret_regs lbl lbl' def
 400
 401   | RTL.St_cond (srcr, lbl_true, lbl_false) ->
 402     add_graph lbl (ERTL.St_cond (srcr, lbl_true, lbl_false)) def
 403
 404   | RTL.St_return ret_regs ->
 405     add_graph lbl (ERTL.St_return ret_regs) def
 406
 407   | RTL.St_tailcall_id _ | RTL.St_tailcall_ptr _ ->
 408     assert false
 409     (* Impossible: the RTL program is supposed to be simplified:
 410        no tailcalls. *)
 411
 412 let translate_internal def =
 413   let nb_params = List.length (def.RTL.f_params) in
 414   (* The stack size is augmented by the number of parameters that cannot fit
 415      into physical registers. *)
 416   let added_stacksize = max 0 (nb_params - (List.length I8051.parameters)) in
 417   let def' =
 418     { ERTL.f_luniverse = def.RTL.f_luniverse ;
 419       ERTL.f_runiverse = def.RTL.f_runiverse ;
 420       ERTL.f_params    = nb_params ;
 421       (* ERTL does not know about parameter registers. We need to add them to
 422          the locals. *)
 423       ERTL.f_locals    = Register.Set.union def.RTL.f_locals
 424                          (Register.Set.of_list def.RTL.f_params) ;
 425       ERTL.f_stacksize = def.RTL.f_stacksize + added_stacksize ;
 426       ERTL.f_graph     = Label.Map.empty ;
 427       ERTL.f_entry     = def.RTL.f_entry ;
 428       ERTL.f_exit      = def.RTL.f_exit } in
 429   let def' = Label.Map.fold translate_stmt def.RTL.f_graph def' in
 430   let def' = add_pro_and_epilogue def.RTL.f_params def.RTL.f_result def' in
 431   def'
 432
 433
 434 let translate_funct (id, def) =
 435   let def' = match def with
 436     | RTL.F_int def -> ERTL.F_int (translate_internal def)
 437     | RTL.F_ext def -> ERTL.F_ext def
 438   in
 439   (id, def')
 440
 441
 442 (* Move the first cost label of each function at the beginning of the
 443    function. Indeed, the instructions for calling conventions (stack allocation
 444    for example) are added at the very beginning of the function, thus before the
 445    first cost label. *)
 446
 447 let generate stmt def =
 448   let entry = Label.Gen.fresh def.ERTL.f_luniverse in
 449   { def with
 450     ERTL.f_graph = Label.Map.add entry stmt def.ERTL.f_graph;
 451     ERTL.f_entry = entry
 452   }
 453
 454 let find_and_remove_first_cost_label def =
 455   let rec aux lbl = match Label.Map.find lbl def.ERTL.f_graph with
 456     | ERTL.St_cost (cost_label, next_lbl) ->
 457       let graph = Label.Map.add lbl (ERTL.St_skip next_lbl) def.ERTL.f_graph in
 458       (cost_label, { def with ERTL.f_graph = graph })
 459     | ERTL.St_skip lbl | ERTL.St_comment (_, lbl) | ERTL.St_get_hdw (_, _, lbl)
 460     | ERTL.St_set_hdw (_, _, lbl) | ERTL.St_hdw_to_hdw (_, _, lbl)
 461     | ERTL.St_pop (_, lbl) | ERTL.St_push (_, lbl) | ERTL.St_addrH (_, _, lbl)
 462     | ERTL.St_addrL (_, _, lbl) | ERTL.St_int (_, _, lbl)
 463     | ERTL.St_move (_, _, lbl) | ERTL.St_opaccsA (_, _, _, _, lbl)
 464     | ERTL.St_opaccsB (_, _, _, _, lbl)
 465     | ERTL.St_op1 (_, _, _, lbl) | ERTL.St_op2 (_, _, _, _, lbl)
 466     | ERTL.St_clear_carry lbl | ERTL.St_set_carry lbl
 467     | ERTL.St_load (_, _, _, lbl)
 468     | ERTL.St_store (_, _, _, lbl) | ERTL.St_call_id (_, _, lbl)
 469     | ERTL.St_call_ptr (_, _, _, lbl)
 470     | ERTL.St_newframe lbl | ERTL.St_delframe lbl | ERTL.St_framesize (_, lbl)
 471       ->
 472       aux lbl
 473     | ERTL.St_cond _ | ERTL.St_return _ ->
 474       (* No cost label found (no labelling performed). Indeed, the first cost
 475          label must after some linear instructions. *)
 476       assert false
 477   in
 478   aux def.ERTL.f_entry
 479
 480 let move_first_cost_label_up_internal def =
 481   let (cost_label, def) = find_and_remove_first_cost_label def in
 482   generate (ERTL.St_cost (cost_label, def.ERTL.f_entry)) def
 483
 484 let move_first_cost_label_up (id, def) =
 485   let def' = match def with
 486     | ERTL.F_int int_fun ->
 487       ERTL.F_int (move_first_cost_label_up_internal int_fun)
 488     | _ -> def
 489   in
 490   (id, def')
 491
 492 let translate p =
 493   (* We simplify tail calls as regular calls for now. *)
 494   let p = RTLtailcall.simplify p in
 495   (* The tranformation on each RTL function: create an ERTL function and move
 496      its first cost label at the very beginning. *)
 497   let f funct = move_first_cost_label_up (translate_funct funct) in
 498   { ERTL.vars   = p.RTL.vars ;
 499     ERTL.functs = List.map f p.RTL.functs ;
 500     ERTL.main   = p.RTL.main }