source: Deliverables/D2.2/8051/src/RTL/RTLToERTL.ml @ 1589

(** This module provides a translation of [RTL] programs to [ERTL]
    programs. *)


let error_prefix = "RTL to ERTL"
let error = Error.global_error error_prefix


(* Helper functions *)

let change_exit_label lbl def =
  { def with ERTL.f_exit = lbl }

let add_graph lbl stmt def =
  { def with ERTL.f_graph = Label.Map.add lbl stmt def.ERTL.f_graph }

let fresh_label def = Label.Gen.fresh def.ERTL.f_luniverse

let change_label lbl = function
  | ERTL.St_cond _ as inst -> inst
  | ERTL.St_return _ as inst -> inst
  | stmt -> ERTLGraph.fill_succs stmt [lbl]

(* Add a list of instruction in a graph, from one label to another, by creating
   fresh labels inbetween. *)

let rec adds_graph stmt_list start_lbl dest_lbl def = match stmt_list with
  | [] -> add_graph start_lbl (ERTL.St_skip dest_lbl) def
  | [stmt] ->
    add_graph start_lbl (change_label dest_lbl stmt) def
  | stmt :: stmt_list ->
    let tmp_lbl = fresh_label def in
    let stmt = change_label tmp_lbl stmt in
    let def = add_graph start_lbl stmt def in
    adds_graph stmt_list tmp_lbl dest_lbl def

(* Process a list of function that adds a list of instructions to a graph, from
   one label to another, and by creating fresh labels inbetween. *)

let rec add_translates translate_list start_lbl dest_lbl def =
  match translate_list with
    | [] -> add_graph start_lbl (ERTL.St_skip dest_lbl) def
    | [trans] -> trans start_lbl dest_lbl def
    | trans :: translate_list ->
      let tmp_lbl = fresh_label def in
      let def = trans start_lbl tmp_lbl def in
      add_translates translate_list tmp_lbl dest_lbl def

let fresh_reg def =
  let r = Register.fresh def.ERTL.f_runiverse in
  let locals = Register.Set.add r def.ERTL.f_locals in
  ({ def with ERTL.f_locals = locals }, r)

let rec fresh_regs def n =
  if n = 0 then (def, [])
  else
    let (def, res) = fresh_regs def (n-1) in
    let (def, r) = fresh_reg def in
    (def, r :: res)


(* Translation *)

let save_hdws l =
  let f (destr, srcr) start_lbl =
    adds_graph [ERTL.St_get_hdw (destr, srcr, start_lbl)] start_lbl in
  List.map f l

let restore_hdws l =
  let f (srcr, destr) start_lbl =
    adds_graph [ERTL.St_set_hdw (destr, srcr, start_lbl)] start_lbl in
  List.map f l

let get_params_hdw params =
  if List.length params = 0 then
    [fun start_lbl -> adds_graph [ERTL.St_skip start_lbl] start_lbl]
  else
    let l = MiscPottier.combine params I8051.parameters in
    save_hdws l

let get_param_stack off destr start_lbl dest_lbl def =
  let (def, addr1) = fresh_reg def in
  let (def, addr2) = fresh_reg def in
  let (def, tmpr) = fresh_reg def in
  adds_graph
    [ERTL.St_framesize (addr1, start_lbl) ;
     ERTL.St_op2 (I8051.Sub, addr1, RTL.Reg addr1, RTL.Imm (off+I8051.int_size),
                  start_lbl) ;
     ERTL.St_get_hdw (tmpr, I8051.spl, start_lbl) ;
     ERTL.St_op2 (I8051.Add, addr1, RTL.Reg addr1, RTL.Reg tmpr, start_lbl) ;
     ERTL.St_get_hdw (tmpr, I8051.sph, start_lbl) ;
     ERTL.St_op2 (I8051.Addc, addr2, RTL.Reg tmpr, RTL.Imm 0, start_lbl) ;
     ERTL.St_load (destr, RTL.Reg addr1, RTL.Reg addr2, start_lbl)]
    start_lbl dest_lbl def

let get_params_stack params =
  if List.length params = 0 then
    [fun start_lbl -> adds_graph [ERTL.St_skip start_lbl] start_lbl]
  else
    let f i r = get_param_stack i r in
    MiscPottier.mapi f params

(* Parameters are taken from the physical parameter registers first. If there
   are not enough such of these, then the remaining parameters are taken from
   the stack. *)

let get_params params =
  let n = min (List.length params) (List.length I8051.parameters) in
  let (hdw_params, stack_params) = MiscPottier.split params n in
  (get_params_hdw hdw_params) @ (get_params_stack stack_params)

let add_prologue params sral srah sregs def =
  let start_lbl = def.ERTL.f_entry in
  let tmp_lbl = fresh_label def in
  let last_stmt = Label.Map.find start_lbl def.ERTL.f_graph in
  let def =
    add_translates
      ([adds_graph [ERTL.St_comment ("Prologue", start_lbl)]] @
       (* new frame *)
       (adds_graph [ERTL.St_comment ("New frame", start_lbl) ;
                    ERTL.St_newframe start_lbl]) ::
       (* save the return address *)
       (adds_graph [ERTL.St_comment ("Save return address", start_lbl) ;
                    ERTL.St_pop (sral, start_lbl) ;
                    ERTL.St_pop (srah, start_lbl)]) ::
       (* save callee-saved registers *)
       [adds_graph [ERTL.St_comment ("Save callee-saved registers",
                                     start_lbl)]] @
       (save_hdws sregs) @
       (* fetch parameters *)
       [adds_graph [ERTL.St_comment ("Fetch parameters", start_lbl)]] @
       (get_params params) @
       [adds_graph [ERTL.St_comment ("End Prologue", start_lbl)]])
      start_lbl tmp_lbl def in
  add_graph tmp_lbl last_stmt def


(* Save the result of a function in a place that cannot be written, even after
   register allocation. This way, the cleaning sequence of returning from a
   function will not interfere with the result value, that can be restored right
   before jumping out of the function. *)

let save_return ret_regs start_lbl dest_lbl def =
  let ((common1, rest1), (common2, _)) =
    MiscPottier.reduce I8051.sts ret_regs in
  let f_save st r = ERTL.St_set_hdw (st, RTL.Reg r, start_lbl) in
  let saves = List.map2 f_save common1 common2 in
  let f_default st = ERTL.St_set_hdw (st, RTL.Imm 0, start_lbl) in
  let defaults = List.map f_default rest1 in
  adds_graph (saves @ defaults) start_lbl dest_lbl def

let assign_result start_lbl =
  let ((common1, _), (common2, _)) = MiscPottier.reduce I8051.rets I8051.sts in
  let f ret st = ERTL.St_hdw_to_hdw (ret, st, start_lbl) in
  let insts = List.map2 f common1 common2 in
  adds_graph insts start_lbl

let add_epilogue ret_regs sral srah sregs def =
  let start_lbl = def.ERTL.f_exit in
  let tmp_lbl = fresh_label def in
  let last_stmt = Label.Map.find start_lbl def.ERTL.f_graph in
  let def =
    add_translates
      ([adds_graph [ERTL.St_comment ("Epilogue", start_lbl)]] @
       (* save return value *)
       [save_return ret_regs] @
       (* restore callee-saved registers *)
       [adds_graph [ERTL.St_comment ("Restore callee-saved registers",
                                     start_lbl)]] @
       (restore_hdws sregs) @
       (* restore the return address *)
       [adds_graph [ERTL.St_comment ("Restore return address", start_lbl) ;
                    ERTL.St_push (RTL.Reg srah, start_lbl) ;
                    ERTL.St_push (RTL.Reg sral, start_lbl)]] @
       (* delete frame *)
       [adds_graph [ERTL.St_comment ("Delete frame", start_lbl) ;
                    ERTL.St_delframe start_lbl]] @
       (* assign the result to actual return registers *)
       [adds_graph [ERTL.St_comment ("Set result", start_lbl)]] @
       [assign_result] @
       [adds_graph [ERTL.St_comment ("End Epilogue", start_lbl)]])
      start_lbl tmp_lbl def in
  let def = add_graph tmp_lbl last_stmt def in
  change_exit_label tmp_lbl def


let allocate_regs saved def =
  let f r (def, sregs) =
    let (def, r') = fresh_reg def in
    (def, (r', r) :: sregs) in
  I8051.RegisterSet.fold f saved (def, [])

let add_pro_and_epilogue params ret_regs def =
  (* Allocate registers to hold the return address. *)
  let (def, sral) = fresh_reg def in
  let (def, srah) = fresh_reg def in
  (* Allocate registers to save callee-saved registers. *)
  let (def, sregs) = allocate_regs I8051.callee_saved def in
  (* Add a prologue and a epilogue. *)
  let def = add_prologue params sral srah sregs def in
  let sregs = List.map (fun (r, r') -> (RTL.Reg r, r')) sregs in
  let def = add_epilogue ret_regs sral srah sregs def in
  def


let set_params_hdw params =
  if List.length params = 0 then
    []
  else
    let l = MiscPottier.combine params I8051.parameters in
    restore_hdws l

let set_param_stack off srcr start_lbl dest_lbl def =
  let (def, addr1) = fresh_reg def in
  let (def, addr2) = fresh_reg def in
  let (def, tmpr) = fresh_reg def in
  adds_graph
    [ERTL.St_get_hdw (tmpr, I8051.spl, start_lbl) ;
     ERTL.St_clear_carry start_lbl ;
     ERTL.St_op2 (I8051.Sub, addr1, RTL.Reg tmpr, RTL.Imm (off+I8051.int_size),
                  start_lbl) ;
     ERTL.St_get_hdw (tmpr, I8051.sph, start_lbl) ;
     ERTL.St_op2 (I8051.Sub, addr2, RTL.Reg tmpr, RTL.Imm 0, start_lbl) ;
     ERTL.St_store (RTL.Reg addr1, RTL.Reg addr2, srcr, start_lbl)]
    start_lbl dest_lbl def

let set_params_stack params =
  if List.length params = 0 then
    [fun start_lbl -> adds_graph [ERTL.St_skip start_lbl] start_lbl]
  else
    let f i r = set_param_stack i r in
    MiscPottier.mapi f params

(* Parameters are put in the physical parameter registers first. If there are
   not enough such of these, then the remaining parameters are passed on the
   stack. *)

let set_params params =
  let n = min (List.length params) (List.length I8051.parameters) in
  let (hdw_params, stack_params) = MiscPottier.split params n in
  (set_params_hdw hdw_params) @ (set_params_stack stack_params)

(* Fetching the result depends on the type of the function, or say, the number
   of registers that are waiting for a value. Temporary non allocatable
   registers are used. Indeed, moving directly from DPL to a pseudo-register may
   cause a bug: DPL might be used to compute the address of the
   pseudo-register. *)

let fetch_result ret_regs start_lbl =
  let ((common1, _), (common2, _)) = MiscPottier.reduce I8051.sts I8051.rets in
  let f_save st ret = ERTL.St_hdw_to_hdw (st, ret, start_lbl) in
  let saves = List.map2 f_save common1 common2 in
  let ((common1, _), (common2, _)) = MiscPottier.reduce ret_regs I8051.sts in
  let f_restore r st = ERTL.St_get_hdw (r, st, start_lbl) in
  let restores = List.map2 f_restore common1 common2 in
  adds_graph (saves @ restores) start_lbl

(* When calling a function, we need to set its parameters in specific locations:
   the physical parameter registers as much as possible, and then the stack
   below. When the called function returns, we put the result where the calling
   function expect it to be. *)
let translate_call stmt args ret_regs start_lbl dest_lbl def =
  let nb_args = List.length args in
  add_translates
    ([adds_graph [ERTL.St_comment ("Starting a call", start_lbl)] ;
      adds_graph [ERTL.St_comment ("Setting up parameters", start_lbl)]] @
     set_params args @
     [adds_graph [stmt nb_args] ;
      adds_graph [ERTL.St_comment ("Fetching result", start_lbl)] ;
      fetch_result ret_regs ;
      adds_graph [ERTL.St_comment ("End of call sequence", start_lbl)]])
    start_lbl dest_lbl def

(*
  let translate_tailcall_id f args start_lbl def = def (* TODO *)
*)

let translate_stmt lbl stmt def = match stmt with

  | RTL.St_skip lbl' ->
    add_graph lbl (ERTL.St_skip lbl') def

  | RTL.St_cost (cost_lbl, lbl') ->
    add_graph lbl (ERTL.St_cost (cost_lbl, lbl')) def

  | RTL.St_ind_0 (i, lbl') ->
    add_graph lbl (ERTL.St_ind_0 (i, lbl')) def

  | RTL.St_ind_inc (i, lbl') ->
    add_graph lbl (ERTL.St_ind_inc (i, lbl')) def

  | RTL.St_addr (r1, r2, x, lbl') ->
    adds_graph
      [ERTL.St_addrL (r1, x, lbl) ; ERTL.St_addrH (r2, x, lbl) ;]
      lbl lbl' def

  | RTL.St_stackaddr (r1, r2, lbl') ->
    adds_graph
      [ERTL.St_get_hdw (r1, I8051.spl, lbl) ;
       ERTL.St_get_hdw (r2, I8051.sph, lbl)]
      lbl lbl' def

  (* | RTL.St_int (r, i, lbl') -> *)
  (*   add_graph lbl (ERTL.St_int (r, i, lbl')) def *)

  | RTL.St_move (r1, r2, lbl') ->
    add_graph lbl (ERTL.St_move (r1, r2, lbl')) def

  | RTL.St_opaccs (op, destr1, destr2, srcr1, srcr2, lbl') ->
    adds_graph [ERTL.St_opaccsA (op, destr1, srcr1, srcr2, lbl) ;
                ERTL.St_opaccsB (op, destr2, srcr1, srcr2, lbl) ;]
      lbl lbl' def

  | RTL.St_op1 (op1, destr, srcr, lbl') ->
    add_graph lbl (ERTL.St_op1 (op1, destr, srcr, lbl')) def

  | RTL.St_op2 (op2, destr, srcr1, srcr2, lbl') ->
    add_graph lbl (ERTL.St_op2 (op2, destr, srcr1, srcr2, lbl')) def

  | RTL.St_clear_carry lbl' ->
    add_graph lbl (ERTL.St_clear_carry lbl') def

  | RTL.St_set_carry lbl' ->
    add_graph lbl (ERTL.St_set_carry lbl') def

  | RTL.St_load (destr, addr1, addr2, lbl') ->
    add_graph lbl (ERTL.St_load (destr, addr1, addr2, lbl')) def

  | RTL.St_store (addr1, addr2, srcr, lbl') ->
    add_graph lbl (ERTL.St_store (addr1, addr2, srcr, lbl')) def

  | RTL.St_call_id (f, args, ret_regs, lbl') ->
    let stmt nb_args = ERTL.St_call_id (f, nb_args, lbl) in
    translate_call stmt args ret_regs lbl lbl' def

  | RTL.St_call_ptr (f1, f2, args, ret_regs, lbl') ->
    let stmt nb_args = ERTL.St_call_ptr (f1, f2, nb_args, lbl) in
    translate_call stmt args ret_regs lbl lbl' def

  (*
    | RTL.St_tailcall_id (f, args) ->
    translate_tailcall_id f args lbl def

    | RTL.St_tailcall_ptr _ ->
    def (* TODO *)
  *)

  | RTL.St_cond (srcr, lbl_true, lbl_false) ->
    add_graph lbl (ERTL.St_cond (srcr, lbl_true, lbl_false)) def

  | RTL.St_return ->
    add_graph lbl (ERTL.St_return) def

  | RTL.St_tailcall_id _ | RTL.St_tailcall_ptr _ ->
    assert false (* impossible: the RTL program is supposed to be simplified:
                    no tailcalls. *)


let translate_internal def =
  let nb_params = List.length (def.RTL.f_params) in
  (* The stack size is augmented by the number of parameters that cannot fit
     into physical registers. *)
  let added_stacksize = max 0 (nb_params - (List.length I8051.parameters)) in
  let def' =
    { ERTL.f_luniverse = def.RTL.f_luniverse ;
      ERTL.f_runiverse = def.RTL.f_runiverse ;
      ERTL.f_params    = nb_params ;
      (* ERTL does not know about parameter registers. We need to add them to
         the locals. *)
      ERTL.f_locals    = Register.Set.union def.RTL.f_locals
                         (Register.Set.of_list def.RTL.f_params) ;
      ERTL.f_stacksize = def.RTL.f_stacksize + added_stacksize ;
      ERTL.f_graph     = Label.Map.empty ;
      ERTL.f_entry     = def.RTL.f_entry ;
      ERTL.f_exit      = def.RTL.f_exit } in
  let def' = Label.Map.fold translate_stmt def.RTL.f_graph def' in
  let def' = add_pro_and_epilogue def.RTL.f_params def.RTL.f_result def' in
  def'


let translate_funct (id, def) =
  let def' = match def with
    | RTL.F_int def -> ERTL.F_int (translate_internal def)
    | RTL.F_ext def -> ERTL.F_ext def
  in
  (id, def')


(* Move the first cost label of each function at the beginning of the
   function. Indeed, the instructions for calling conventions (stack allocation
   for example) are added at the very beginning of the function, thus before the
   first cost label. *)

let generate stmt def =
  let entry = Label.Gen.fresh def.ERTL.f_luniverse in
  let def =
    { def with ERTL.f_graph = Label.Map.add entry stmt def.ERTL.f_graph } in
  { def with ERTL.f_entry = entry }

let find_and_remove_first_cost_label def =
  let rec aux lbl = match Label.Map.find lbl def.ERTL.f_graph with
    | ERTL.St_cost (cost_label, next_lbl) ->
      let graph = Label.Map.add lbl (ERTL.St_skip next_lbl) def.ERTL.f_graph in
      (Some cost_label, { def with ERTL.f_graph = graph })
    | ERTL.St_ind_0 (_, lbl) | ERTL.St_ind_inc (_, lbl)
    | ERTL.St_skip lbl | ERTL.St_comment (_, lbl) | ERTL.St_get_hdw (_, _, lbl)
    | ERTL.St_set_hdw (_, _, lbl) | ERTL.St_hdw_to_hdw (_, _, lbl)
    | ERTL.St_pop (_, lbl) | ERTL.St_push (_, lbl) | ERTL.St_addrH (_, _, lbl)
    | ERTL.St_addrL (_, _, lbl) (* | ERTL.St_int (_, _, lbl) *)
    | ERTL.St_move (_, _, lbl) | ERTL.St_opaccsA (_, _, _, _, lbl)
    | ERTL.St_opaccsB (_, _, _, _, lbl)
    | ERTL.St_op1 (_, _, _, lbl) | ERTL.St_op2 (_, _, _, _, lbl)
    | ERTL.St_clear_carry lbl | ERTL.St_set_carry lbl
    | ERTL.St_load (_, _, _, lbl)
    | ERTL.St_store (_, _, _, lbl) | ERTL.St_call_id (_, _, lbl)
    | ERTL.St_call_ptr (_, _, _, lbl)
    | ERTL.St_newframe lbl | ERTL.St_delframe lbl | ERTL.St_framesize (_, lbl)
      ->
      aux lbl
    | ERTL.St_cond _ | ERTL.St_return _ ->
      (* No cost label found (no labelling performed). Indeed, the first cost
         label must after some linear instructions. *)
      (None, def) in
  aux def.ERTL.f_entry

let move_first_cost_label_up_internal def =
  let (cost_label, def) = find_and_remove_first_cost_label def in
  match cost_label with
    | None -> def
    | Some cost_label ->
      generate (ERTL.St_cost (cost_label, def.ERTL.f_entry)) def

let move_first_cost_label_up (id, def) =
  let def' = match def with
    | ERTL.F_int int_fun ->
      ERTL.F_int (move_first_cost_label_up_internal int_fun)
    | _ -> def in
  (id, def')


let translate p =
  (* We simplify tail calls as regular calls for now. *)
  let p = RTLtailcall.simplify p in
  (* The tranformation on each RTL function: create an ERTL function and move
     its first cost label at the very beginning. *)
  let f funct = move_first_cost_label_up (translate_funct funct) in
  { ERTL.vars   = p.RTL.vars ;
    ERTL.functs = List.map f p.RTL.functs ;
    ERTL.main   = p.RTL.main }