source: src/RTL/RTLToERTL.ma @ 3145

include "utilities/RegisterSet.ma".
include "common/Identifiers.ma".
include "RTL/RTL.ma".
include "ERTL/ERTL.ma".
include "joint/TranslateUtils.ma".
include "joint/joint_stacksizes.ma".

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

definition save_hdws :
  ∀globals.list (register×Register) → list (joint_seq ERTL 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 (psd_argument×Register) → list (joint_seq ERTL globals) ≝
  λglobals.
   let restore_hdws_internal ≝
    λdestr_srcr:psd_argument×?.HDW (\snd destr_srcr) ← \fst destr_srcr in
    map ? ? restore_hdws_internal.

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

definition get_param_stack :
  ∀globals.register → register → register →
  list (joint_seq ERTL globals) ≝
  λglobals,addr1,addr2,destr.
  (* liveness analysis will erase the last useless ops *)
  [ LOAD ?? destr addr1 addr2 ;
    addr1 ← addr1 .Add. (int_size : Byte) ;
    addr2 ← addr2 .Addc. zero_byte
  ].

definition get_params_stack :
  ∀globals.register → register → register → list register →
  list (joint_seq ERTL globals) ≝
  λglobals.
  λtmpr,addr1,addr2,params.
  let params_length_byte : Byte ≝ bitvector_of_nat ? (|params|) in
  [ (ertl_frame_size tmpr : joint_seq ??) ;
    CLEAR_CARRY ?? ;
    tmpr ← tmpr .Sub. params_length_byte ; (* will be constant later *)
    PSD addr1 ← HDW RegisterSPL ;
    PSD addr2 ← HDW RegisterSPH ;
    addr1 ← addr1 .Add. tmpr ;
    addr2 ← addr2 .Addc. zero_byte ] @    
  flatten … (map ?? (get_param_stack globals addr1 addr2) params).

definition get_params ≝
  λglobals,tmpr,addr1,addr2,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 … tmpr addr1 addr2 stack_params.

definition save_return :
  ∀globals.list psd_argument → list (joint_seq ERTL 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 : psd_argument.HDW st ← r) commonl commonr crl_proof @
    map … (λst.HDW st ← zero_byte) restl
  ].

definition assign_result : ∀globals.list (joint_seq ERTL 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
  ].

lemma All_map2 : ∀A,B,C,P,R,f,l1,l2,prf.
 All2 A B P l1 l2 →
 (∀x,y.P x y → R (f x y)) →
 All C R (map2 A B C f l1 l2 prf).
#A #B #C #P #R #f #l1 elim l1 -l1
[ * [ #prf * #H % ] #hd' #tl'
| #hd #tl #IH * [2: #hd' #tl' ]
] #prf normalize in prf; destruct
* #H1 #H2 #H % [ @H @H1 | @IH assumption ] qed.

lemma All2_True : ∀A,B,l1,l2.|l1| = |l2| → All2 A B (λ_.λ_.True) l1 l2.
#A #B #l1 elim l1 -l1
[ * [ #prf % ] #hd' #tl'
| #hd #tl #IH * [2: #hd' #tl' ]
] #prf normalize in prf; destruct %{I} @IH assumption
qed.

lemma All_True : ∀A,l.All A (λ_.True) l.
#A #l elim l -l [ % | #hd #tl #IH %{I IH} ] qed.

definition epilogue :
  ∀globals.list register → register → register → list (register × Register) →
  Σl : list (joint_seq ERTL globals).
  All (joint_seq ??) (λs.step_labels ?? s = [ ]) l ≝
  λglobals,ret_regs,sral,srah,sregs.
  save_return … (map … (Reg ?) ret_regs) @
  restore_hdws … (map … (λpr.〈Reg ? (\fst pr),\snd pr〉) sregs) @
  [ PUSH ERTL ? sral ;
    PUSH … srah ;
    ertl_del_frame ] @
  assign_result globals.
@hide_prf
@All_append
[ whd in match save_return; normalize nodelta
  cases (reduce_strong ????) ** #a #b * #c #d #prf normalize nodelta
  @All_append
  [ @(All_map2 … (All2_True … prf)) #x #y #_ %
  | @(All_map … (All_True …)) #x #_ %
  ]
| @All_append
  [ @(All_map … (All_True …)) #x #_ %
  | %{(refl …)} %{(refl …)} %{(refl …)}
    whd in match assign_result;
    generalize in match reduce_strong; #f normalize nodelta
    cases (f ????) #l #prf normalize nodelta
    @(All_map2 … (All2_True … prf)) #x #y #_ %
  ]
]
qed.

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

definition set_params_hdw :
  ∀globals.list psd_argument → list (joint_seq ERTL 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 → psd_argument →
  list (joint_seq ERTL globals) ≝
  λglobals,addr1,addr2,arg.
  [ STORE … addr1 addr2 arg ;
    addr1 ← addr1 .Add. (int_size : Byte) ;
    addr2 ← addr2 .Addc. zero_byte
  ].

definition set_params_stack :
  ∀globals.list psd_argument → bind_new register ? ≝
  λglobals,params.
  νaddr1,addr2 in
  let params_length_byte : Byte ≝ bitvector_of_nat ? (|params|) in
  [ PSD addr1 ← HDW RegisterSPL ;
    PSD addr2 ← HDW RegisterSPH ;
    CLEAR_CARRY ?? ;
    addr1 ← addr1 .Sub. params_length_byte ;
    addr2 ← addr2 .Sub. zero_byte
  ] @
  flatten … (map … (set_param_stack globals addr1 addr2) params).

definition set_params :
  ∀globals.list psd_argument →
  Σb : bind_new register (list (joint_seq ERTL globals)).
  BindNewP … (All (joint_seq ??) (λs.step_labels … s = [ ])) b ≝
  λ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.
@hide_prf
  @mp_bind [3: #l1 #H1 @mp_bind [3: #l2 #H2 @(All_append … H1 H2) ] |*:]
  [ #r1 #r2
    %{(refl …)} %{(refl …)} %{(refl …)} %{(refl …)} %{(refl …)}
    @All_append [ % ]
    elim stack_params [ % ] #hd #tl #IH whd in match flatten; normalize nodelta
    whd in match (foldr ?????); %{(refl …)} %{(refl …)} %{(refl …)} @IH
  | whd whd in match set_params_hdw; normalize nodelta
    whd in match restore_hdws; normalize nodelta @(All_map … (All_True …))
    #a #_ %
  ]
qed.

definition fetch_result :
  ∀globals.list register →
  Σl : list (joint_seq ERTL globals).
  All (joint_seq ??) (λs.step_labels ?? s = [ ]) l ≝
  λ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
    ]
  ].
@hide_prf
@All_append
[ @(All_map2 … (All2_True … crl_proof)) #x #y #_ %
| cases (reduce_strong ????) #l #prf normalize nodelta
  @(All_map2 … (All2_True … prf)) #x #y #_ %
]
qed.

definition translate_step :
  ∀globals.label → joint_step RTL globals →
    bind_step_block ERTL globals ≝
  λglobals.λ_.λs.
  match s return λ_.bind_step_block ?? with
  [ step_seq s ⇒
    bret … match s return λ_.step_block ?? with
    [ PUSH _ ⇒ [ ] (*CSC: XXXX should not be in the syntax *)
    | POP _ ⇒ [ ] (*CSC: XXXX should not be in the syntax *)
    | MOVE rs ⇒ [PSD (\fst rs) ← \snd rs]
    | ADDRESS x prf off r1 r2 ⇒
      [ADDRESS ERTL ? x prf off r1 r2]
    | OPACCS op destr1 destr2 srcr1 srcr2 ⇒
      [OPACCS ERTL ? op destr1 destr2 srcr1 srcr2]
    | OP1 op1 destr srcr ⇒
      [OP1 ERTL ? op1 destr srcr]
    | OP2 op2 destr srcr1 srcr2 ⇒
      [OP2 ERTL ? op2 destr srcr1 srcr2]
    | CLEAR_CARRY ⇒
      [CLEAR_CARRY ??]
    | SET_CARRY ⇒
      [SET_CARRY ??]
    | LOAD destr addr1 addr2 ⇒
      [LOAD ERTL ? destr addr1 addr2]
    | STORE addr1 addr2 srcr ⇒
      [STORE ERTL ? addr1 addr2 srcr]
    | COMMENT msg ⇒
      [COMMENT … msg]
    | extension_seq ext ⇒
      match ext return λ_.step_block ?? with
      [ rtl_stack_address addr1 addr2 ⇒
        [ PSD addr1 ← HDW RegisterSPL ; PSD addr2 ← HDW RegisterSPH ]
      ]
    ]
  | COST_LABEL lbl ⇒
    bret … 〈[ ], λ_.COST_LABEL ERTL ? lbl, [ ]〉
  | CALL f args ret_regs ⇒
    ! pref ← pi1 … (set_params ? args) ;
    bret ? (step_block ??) 〈add_dummy_variance … pref,
             λ_.CALL ERTL ? f (|args|) it,
             fetch_result ? ret_regs〉
  | COND r ltrue ⇒
    bret … 〈[ ], λ_.COND ERTL ? r ltrue, [ ]〉
  ].

definition translate_fin_step :
  ∀globals.list register → register → register → list (register × Register) →
    label → joint_fin_step RTL →
    bind_fin_block ERTL globals ≝
  λglobals.λret_regs,ral,rah,to_restore.λ_.λs.
  match s return λ_.bind_fin_block ERTL ? with
  [ GOTO lbl' ⇒ bret … 〈[ ], GOTO … lbl'〉
  | RETURN ⇒ bret … 〈epilogue … ret_regs ral rah to_restore, RETURN ?〉
  | TAILCALL b _ _ ⇒ match b in False with [ ]
  ].

definition allocate_regs :
  ∀X : Type[0].
  (list (register×Register) → bind_new register X) →
  bind_new register X ≝
  λX,f.
  let allocate_regs_internal ≝
    λacc : bind_new register (list (register × Register)).
    λr: Register.
    ! tl ← acc ;
    νr' in return (〈r', r〉 :: tl) in
  ! to_save ← foldl ?? allocate_regs_internal (return [ ]) RegisterCalleeSaved ;
  f to_save.

definition translate_data :
 ∀globals.joint_closed_internal_function RTL globals →
 bound_b_graph_translate_data RTL ERTL globals ≝
λglobals,def.
let params ≝ joint_if_params … def in
let new_stacksize ≝
  joint_if_stacksize … def + (|params| - |RegisterParams|) in
allocate_regs ?
  (λto_save.
    νral,rah,tmpr,addr1,addr2 in
    ! prologue ← prologue globals params ral rah tmpr addr1 addr2 to_save ;
    return mk_b_graph_translate_data RTL ERTL globals
    (* init_ret ≝ *) it
    (* init_params ≝ *) (|params|)
    (* init_stack_size ≝ *) new_stacksize
    (* added_prologue ≝ *) prologue
    (* new_regs ≝ *) (reverse … (addr2 :: addr1 :: tmpr :: rah :: ral :: map … (λx.\fst x) to_save))
    (* f_step ≝ *) (translate_step globals)
    (* f_fin ≝ *) (translate_fin_step globals (joint_if_result … def) ral rah to_save)
    ????).
@hide_prf
[1,2: cases daemon (* TODO *)
| #l #c %
| #l * [ #c' | #f #args #dest | #a #ltrue | #s ] #c whd
  [2: #r1 #r2 ] whd #l' #EQ destruct try %
  cases s in EQ; whd in match ensure_step_block; normalize nodelta
  try #a try #b try #c try #d try #e try #f destruct
  cases a in b; #a1 #a2 normalize nodelta #EQ destruct
| #r1 #r2 #r3 #r4 #r5 #r6 #r7 #r8 #ral #rah #tmpr #addr1 #addr2
% (* XXX: FAILS, unintentional list reversal??? *)
]
(* #l *
[ #l whd %{I} %{I} %1 %
| whd %{I} cases (epilogue ?????) @All_mp #s #EQ whd >EQ %
| *
| #c %{I} %{I} #l %
| #called #args #dest @(mp_bind … (BindNewP …))
  [2: @(pi2 ? (λ_.?)) |*:] #l1 #H1 whd % [%]
    [ @(All_map … H1) #a #EQ #l whd >EQ %
    | #l %
    | cases (fetch_result ??) @All_mp #s #EQ whd >EQ %
    ]
| #a #l_true whd %{I} %{I} #l %{I} %2 %1 %
| * try #a try #b try #c try #d try #e whd
  try (%{I} %{I} #l %)
  cases a -a #a #b whd %{I} % [ %{I} ] #l %
]*)
qed.

(* removing this because of how insert_prologue is now defined
definition generate ≝
  λglobals.
  λstmt.
  λdef: joint_internal_function globals ERTL.
  let 〈entry, def〉 ≝ fresh_label … def in
  let graph ≝ add … (joint_if_code … def) entry stmt in
   set_joint_if_graph … (ERTL 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 ERTL1 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_ 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 ≝
  b_graph_transform_program … translate_data.

lemma RTLToERTL_monotone_stacksizes :
∀p_in.let p_out ≝ rtl_to_ertl p_in in
stack_cost_model_le (stack_cost ? p_in) (stack_cost ? p_out).
#p_in whd
@list_map_opt_All2
[ @(λid_def1,id_def2.
   match \snd id_def1 with
   [ Internal f1 ⇒
     match \snd id_def2 with
     [ Internal f2 ⇒
       \fst id_def1 = \fst id_def2 ∧
       le (joint_if_stacksize … f1) (joint_if_stacksize … f2)
     | _ ⇒ False
     ]
   | External _ ⇒ match \snd id_def2 with [ Internal _ ⇒ False | External _ ⇒ True ]
   ])
| * #id * #f1 * #id' * #f2 normalize nodelta [|*: * %]
  ** #H %{H} % ]
@All2_of_map * #id * #f normalize nodelta [2: %]
% [%]
cases (b_graph_translate ?????) #f_out * #data
* *[2:#r1*[2:#r2*[2:#r3*[2:#r4*[2:#r5*[2:#r6*[2:#r7*[2:#r8*
  [2:#r9*[2:#r10*[2:#r11*[2:#r12*[2:#r13*[2:#r14 #tl]]]]]]]]]]]]]]
* #f_lbls * #f_regs * try ( * @False) whd in ⊢ (%→?); #EQ_data
#props >(ss_def_out_eq … props) >EQ_data
generalize in match (joint_if_stacksize ???); generalize in match (length ??-length ??);
-p_in //
qed.