source: src/RTL/RTLToERTL_paolo.ma @ 2183

include "RTL/RTLTailcall_paolo.ma".
include "utilities/RegisterSet.ma".
include "common/Identifiers.ma".
include "ERTL/ERTL_paolo.ma".
include "joint/TranslateUtils_paolo.ma".

include alias "basics/lists/list.ma".

definition save_hdws :
  ∀globals.list (register×Register) → list (joint_seq ertl_params globals) ≝
 λglobals.
  let save_hdws_internal ≝
   λdestr_srcr.PSD (\fst destr_srcr) ← HDW (\snd destr_srcr) in
  map ?? save_hdws_internal.

definition restore_hdws :
  ∀globals.list (rtl_argument×Register) → list (joint_seq ertl_params globals) ≝
  λglobals.
   let restore_hdws_internal ≝
    λdestr_srcr:rtl_argument×?.HDW (\snd destr_srcr) ← \fst destr_srcr in
    map ? ? restore_hdws_internal.

definition get_params_hdw :
  ∀globals.list register → list (joint_seq ertl_params globals) ≝
  λglobals,params.
  save_hdws … (zip_pottier … params RegisterParams).

(* Paolo: The following can probably be done way more efficiently with INC DPTR *)

definition get_param_stack :
  ∀globals.register → register → nat → register →
  list (joint_seq ertl_params globals) ≝
  λglobals,addr1,addr2,off,destr.
  let int_offset : Byte ≝ \snd (half_add ? (bitvector_of_nat ? off) int_size) in
  [ (ertl_frame_size addr1 : joint_seq ??) ;
    CLEAR_CARRY … ;
    addr1 ← addr1 .Sub. int_offset ; (* are we sure carry bit is unimportant? *)
    PSD destr ← HDW RegisterSPL ;
    addr1 ← addr1 .Add. destr ;
    PSD addr2 ← HDW RegisterSPH ;
    addr2 ← addr2 .Addc. 0 ;
    LOAD … destr addr1 addr2
  ].

definition get_params_stack :
  ∀globals.list register →
  bind_new (localsT ertl_params) (list (joint_seq ertl_params globals)) ≝
  λglobals,params.
  νaddr1,addr2 in
  flatten … (mapi ?? (get_param_stack globals addr1 addr2) params).

definition get_params ≝
  λglobals,params.
  let n ≝ min (length … params) (length … RegisterParams) in
  let 〈hdw_params, stack_params〉 ≝ list_split … n params in
  get_params_hdw globals hdw_params @@ get_params_stack … stack_params.

definition prologue :
  ∀globals.list register → register → register → list (register×Register) →
  bind_new (localsT ertl_params) (list (joint_seq ertl_params globals)) ≝
  λglobals,params,sral,srah,sregs.
  [ (ertl_new_frame : joint_seq ??) ;
    POP … sral ;
    POP … srah
  ] @@ save_hdws … sregs @@ get_params … params.

definition save_return :
  ∀globals.list rtl_argument → list (joint_seq ertl_params globals) ≝
  λglobals,ret_regs.
  match reduce_strong ? ? RegisterSTS ret_regs with
  [ mk_Sig crl crl_proof ⇒
    let commonl ≝ \fst (\fst crl) in
    let commonr ≝ \fst (\snd crl) in
    let restl ≝ \snd (\fst crl) in
    (* let restr ≝ \snd (\snd crl) in *)
    map2 … (λst.λr : rtl_argument.HDW st ← r) commonl commonr crl_proof @
    map … (λst.HDW st ← 0) restl
  ].

definition assign_result : ∀globals.list (joint_seq ertl_params globals) ≝
  λglobals.
  match reduce_strong ?? RegisterRets RegisterSTS with
  [ mk_Sig crl crl_proof ⇒
    let commonl ≝ \fst (\fst crl) in
    let commonr ≝ \fst (\snd crl) in
    map2 … (λret,st.HDW ret ← HDW st) commonl commonr crl_proof
  ].

definition epilogue :
  ∀globals.list register → register → register → list (register × Register) →
  list (joint_seq ertl_params globals) ≝
  λglobals,ret_regs,sral,srah,sregs.
  save_return … (map … Reg ret_regs) @
  restore_hdws … (map … (λpr.〈Reg (\fst pr),\snd pr〉) sregs) @
  [ PUSH ertl_params ? srah ;
    PUSH … sral ;
    ertl_del_frame ] @
  assign_result globals.

definition allocate_regs :
  ∀globals,rs.rs_set rs →
  state_monad (joint_internal_function globals ertl_params) (list (register×Register)) ≝
  λglobals,rs,saved,def.
   let allocate_regs_internal ≝
    λr: Register.
    λdef_sregs.
    let 〈def, r'〉 ≝ rtl_ertl_fresh_reg … (\fst def_sregs) in
    〈def, 〈r', r〉::\snd def_sregs〉 in
  rs_fold ?? allocate_regs_internal saved 〈def, [ ]〉.

definition add_pro_and_epilogue :
  ∀globals.list register → list register →
  joint_internal_function globals ertl_params →
  joint_internal_function globals ertl_params ≝
  λglobals,params,ret_regs,def.
  let start_lbl ≝ joint_if_entry … def in
  let end_lbl ≝ joint_if_exit … def in
  state_run … def (
    ! sral ← rtl_ertl_fresh_reg … ;
    ! srah ← rtl_ertl_fresh_reg … ;
    ! sregs ← allocate_regs … register_list_set RegisterCalleeSaved ;
    ! prologue' ← bcompile … (rtl_ertl_fresh_reg …) (prologue … params sral srah sregs) ;
    let epilogue' ≝ epilogue … ret_regs sral srah sregs in
    ! def' ← state_get … ;
    let def'' ≝ insert_prologue … prologue' def' in
    return insert_epilogue … epilogue' def''
  ).

definition set_params_hdw :
  ∀globals.list rtl_argument → list (joint_seq ertl_params globals) ≝
  λglobals,params.
  restore_hdws globals (zip_pottier ? ? params RegisterParams).

(* Paolo: The following can probably be done way more efficiently with INC DPTR *)

definition set_param_stack :
  ∀globals.register → register → nat → rtl_argument →
  list (joint_seq ertl_params globals) ≝
  λglobals,addr1,addr2,off,arg.
  let int_off : Byte ≝ \snd (half_add ? (bitvector_of_nat ? off) int_size) in
  [ PSD addr1 ← HDW RegisterSPL ;
    CLEAR_CARRY … ;
    addr1 ← addr1 .Sub. int_off ;
    PSD addr2 ← HDW RegisterSPH ;
    addr2 ← addr2 .Sub. 0 ;
    STORE … addr1 addr2 arg
  ].

definition set_params_stack :
  ∀globals.list rtl_argument → bind_new (localsT ertl_params) ? ≝
  λglobals,params.
  νaddr1,addr2 in
  flatten … (mapi … (set_param_stack globals addr1 addr2) params).

definition set_params ≝
  λglobals,params.
  let n ≝ min (|params|) (|RegisterParams|) in
  let hdw_stack_params ≝ split ? params n in
  let hdw_params ≝ \fst hdw_stack_params in
  let stack_params ≝ \snd hdw_stack_params in
  set_params_hdw globals hdw_params @@ set_params_stack globals stack_params.

definition fetch_result :
  ∀globals.list register → list (joint_seq ertl_params globals) ≝
  λglobals,ret_regs.
  match reduce_strong ?? RegisterSTS RegisterRets with
  [ mk_Sig crl crl_proof ⇒
    let commonl ≝ \fst (\fst crl) in
    let commonr ≝ \fst (\snd crl) in
    map2 … (λst,r.HDW st ← HDW r) commonl commonr crl_proof @
    match reduce_strong ?? ret_regs RegisterSTS with
    [ mk_Sig crl crl_proof ⇒
      let commonl ≝ \fst (\fst crl) in
      let commonr ≝ \fst (\snd crl) in
      map2 … (λret,st.PSD ret ← HDW st) commonl commonr crl_proof
    ]
  ].

definition translate_step :
  ∀globals.label → joint_step rtlntc_params globals →
    bind_seq_block ertl_params globals (joint_step ertl_params globals) ≝
  λglobals.λ_.λs.
  match s return λ_.bind_seq_block ?? (joint_step ??) with
  [ step_seq s ⇒
    match s return λ_.bind_seq_block ?? (joint_step ??) with
    [ PUSH _ ⇒ NOOP … (*CSC: XXXX should not be in the syntax *)
    | POP _ ⇒ NOOP …  (*CSC: XXXX should not be in the syntax *)
    | MOVE rs ⇒ PSD (\fst rs) ←
        match \snd rs with
        [ Reg src ⇒ PSD src
        | Imm b ⇒ INT b
        ]
    | COST_LABEL lbl ⇒
      COST_LABEL … lbl
    | ADDRESS x prf r1 r2 ⇒
      ADDRESS ertl_params ? x prf r1 r2
    | OPACCS op destr1 destr2 srcr1 srcr2 ⇒
      OPACCS ertl_params ? op destr1 destr2 srcr1 srcr2  
    | OP1 op1 destr srcr ⇒
      OP1 ertl_params ? op1 destr srcr
    | OP2 op2 destr srcr1 srcr2 ⇒
      OP2 ertl_params ? op2 destr srcr1 srcr2
    | CLEAR_CARRY ⇒
      CLEAR_CARRY …
    | SET_CARRY ⇒
      SET_CARRY …
    | LOAD destr addr1 addr2 ⇒
      LOAD ertl_params ? destr addr1 addr2
    | STORE addr1 addr2 srcr ⇒
      STORE ertl_params ? addr1 addr2 srcr
    | COMMENT msg ⇒
      COMMENT … msg
    | extension_seq ext ⇒
      match ext with
      [ rtl_stack_address addr1 addr2 ⇒
        [ PSD addr1 ← HDW RegisterSPL ; PSD addr2 ← HDW RegisterSPH ]
      ]
    | CALL_ID f args ret_regs ⇒
      set_params ? args @@
      CALL_ID ertl_params ? f (|args|) it :::
      fetch_result ? ret_regs
    | extension_call c ⇒
      match c with
      [ rtl_call_ptr f1 f2 args dest ⇒
        ?
      ]
    ]
  | COND r ltrue ⇒
    COND ertl_params ? r ltrue
  ]. cases daemon (* pointer call to be ported yet *) qed.

definition translate_fin_step :
  ∀globals.label → joint_fin_step rtlntc_params →
    bind_seq_block ertl_params globals (joint_fin_step ertl_params) ≝
  λglobals.λ_.λs.
  match s with
  [ GOTO lbl' ⇒ GOTO … lbl'
  | RETURN ⇒ RETURN ?
  | tailcall abs ⇒ match abs in void with [ ]
  ].

(* hack with empty graphs used here *)
definition translate_funct :
  ∀globals.joint_internal_function globals rtlntc_params →
    joint_internal_function globals ertl_params ≝
  λglobals,def.
  let nb_params ≝ |joint_if_params ?? def| in
  let added_stacksize ≝ max 0 (minus nb_params (|RegisterParams|)) in
  let new_locals ≝ nub_by ? (eq_identifier ?) ((joint_if_locals … def) @ (joint_if_params … def)) in
  let entry' ≝ pi1 … (joint_if_entry … def) in
  let exit' ≝ pi1 … (joint_if_exit … def) in
  let graph' ≝ add ? ? (empty_map ? (joint_statement ??)) entry' (GOTO … exit') in
  let graph' ≝ add ? ? graph' exit' (RETURN …) in
  let def' ≝
    mk_joint_internal_function globals ertl_params
      (joint_if_luniverse … def) (joint_if_runiverse … def) (joint_if_result … def) (*CSC: different from OCaml code where joint_if_result is unit*)
      nb_params new_locals ((joint_if_stacksize … def) + added_stacksize)
      graph' entry' exit' in
  let def'' ≝ b_graph_translate …
    (rtl_ertl_fresh_reg …)
    def'
    (translate_step globals)
    (translate_fin_step globals)
    def in
  add_pro_and_epilogue ? (joint_if_params ?? def) (joint_if_result ?? def) def'.
>graph_code_has_point @map_mem_prop
[@graph_add_lookup] @graph_add
qed.

(* removing this because of how insert_prologue is now defined
definition generate ≝
  λglobals.
  λstmt.
  λdef: joint_internal_function globals ertl_params.
  let 〈entry, def〉 ≝ fresh_label … def in
  let graph ≝ add … (joint_if_code … def) entry stmt in
   set_joint_if_graph … (ertl_params globals) graph def ??.
  [ (*% [ @entry | @graph_add ]*) cases daemon (*CSC: XXX *)
  | (*cases (joint_if_exit … def) #LBL #LBL_PRF % [ @LBL | @graph_add_lookup @LBL_PRF
    *) cases daemon (*CSC: XXX *)
  ]
qed.

let rec find_and_remove_first_cost_label_internal (globals: list ident)
  (def: ertl_internal_function globals) (lbl: label) (num_nodes: nat)
    on num_nodes ≝
  match num_nodes with
  [ O ⇒ 〈None ?, def〉
  | S num_nodes' ⇒
    match lookup … (joint_if_code … def) lbl with
    [ None ⇒ 〈None ?, def〉
    | Some stmt ⇒ 
      match stmt with
      [ sequential inst lbl ⇒
         match inst with
          [ COST_LABEL cost_lbl ⇒
             〈Some … cost_lbl, add_graph ertl_params1 globals lbl (GOTO … lbl) def〉
          | _ ⇒ find_and_remove_first_cost_label_internal globals def lbl num_nodes' ]
      | RETURN ⇒ 〈None …, def〉
      | GOTO lbl ⇒ find_and_remove_first_cost_label_internal globals def lbl num_nodes'
      ]]].
    
definition find_and_remove_first_cost_label ≝
  λglobals,def.  
    find_and_remove_first_cost_label_internal globals def (joint_if_entry … def) (graph_num_nodes ? (joint_if_code … def)).

definition move_first_cost_label_up_internal ≝
  λglobals,def.
  let 〈cost_label, def〉 ≝ find_and_remove_first_cost_label … def in
  match cost_label with
  [ None ⇒ def
  | Some cost_label ⇒ generate … (sequential ertl_params_ globals (COST_LABEL … cost_label) (joint_if_entry … def)) def
  ].

definition translate_funct ≝ λglobals,def. (move_first_cost_label_up_internal … (translate_funct_internal globals def)).
*)

definition rtl_to_ertl : rtl_program → ertl_program ≝
 λp.
  let p ≝ tailcall_simplify p in (* tailcall simplification here *)
    transform_program ??? p (λvarnames. transf_fundef ?? (translate_funct varnames)).