Changeset 2783 for src


Ignore:
Timestamp:
Mar 6, 2013, 12:09:52 PM (7 years ago)
Author:
piccolo
Message:

modified joint_closed_internal_function definition (added condition on pseudo-registers)
added new record for parameters
modified state definition with option for framesT

Location:
src
Files:
2 added
17 edited

Legend:

Unmodified
Added
Removed
  • src/ERTL/ERTL.ma

    r2645 r2783  
    4141    (* paramsT ≝ *) ℕ.
    4242
    43 definition ERTL ≝ mk_graph_params ERTL_uns.
     43definition regs_from_move_dst : move_dst → list register ≝
     44λm. match m with [PSD r ⇒ [r] | HDW _ ⇒ [ ] ].
     45
     46definition regs_from_move_src : move_src → list register ≝
     47λm. match m with [Imm _ ⇒ [ ] | Reg r ⇒ match r with [PSD r1 ⇒ [r1] | HDW _ ⇒ [ ] ] ].
     48
     49definition ertl_ext_seq_regs : ertl_seq → list register ≝
     50λs.match s with [ertl_frame_size r ⇒ [r] | _ ⇒ [ ]].
     51
     52definition ERTL_functs ≝ mk_get_pseudo_reg_functs ERTL_uns
     53(* acc_a_regs *) (λr.[r])
     54(* acc_b_regs *) (λr.[r])
     55(* acc_a_args *) (λarg.match arg with [ Imm _ ⇒ [ ] | Reg r ⇒ [r]])
     56(* acc_b_args *) (λarg.match arg with [ Imm _ ⇒ [ ] | Reg r ⇒ [r]])
     57(* dpl_regs *) (λr.[r])
     58(* dph_regs *) (λr.[r])
     59(* dpl_args *) (λarg.match arg with [ Imm _ ⇒ [ ] | Reg r ⇒ [r]])
     60(* dph_args *) (λarg.match arg with [ Imm _ ⇒ [ ] | Reg r ⇒ [r]])
     61(* snd_args *) (λarg.match arg with [ Imm _ ⇒ [ ] | Reg r ⇒ [r]])
     62(* pair_move_regs *) (λx.(regs_from_move_dst (\fst x)) @ (regs_from_move_src (\snd x)))
     63(* f_call_args *) (λ_.[ ])
     64(* f_call_dest *) (λ_.[ ])
     65(* ext_seq_regs *) ertl_ext_seq_regs
     66(* params_regs *) (λ_.[ ]).
     67
     68definition ERTL ≝ mk_graph_params (mk_uns_params ERTL_uns ERTL_functs).
    4469definition ertl_program ≝ joint_program ERTL.
    4570
  • src/ERTL/ERTL_semantics.ma

    r2674 r2783  
    3737definition ERTL_state : sem_state_params ≝
    3838  mk_sem_state_params
    39  (* framesT ≝ *) (list (register_env beval × ident))
     39 (* framesT ≝ *) (list (register_env beval × (Σb:block.block_region b=Code)))
    4040 (* empty_framesT ≝ *) [ ]
    4141 (* regsT ≝ *) ertl_reg_env
     
    6464  〈 add … (\fst lenv) reg BVundef, \snd lenv〉.
    6565
     66(* TODO move into ErrorMessage *)
     67axiom FramesEmptyOnPop : ErrorMessage.
     68axiom BlockInFramesCorrupted : ErrorMessage.
     69axiom FrameErrorOnPush : ErrorMessage.
     70axiom FrameErrorOnPop : ErrorMessage.
    6671
    6772definition ertl_save_frame:
    68  call_kind → unit → ident → state_pc ERTL_state → res (state … ERTL_state) ≝
    69  λ_.λ_.λid.λst.
    70   do st ← push_ra … st (pc … st) ;
    71   OK …
    72    (set_frms ERTL_state (〈\fst (regs ERTL_state st),id〉 :: (st_frms … st))
    73     (set_regs ERTL_state 〈empty_map …,\snd (regs … st)〉 st)).
     73 call_kind → unit → state_pc ERTL_state → res (state … ERTL_state) ≝
     74 λ_.λ_.λst.
     75  ! st' ← push_ra … st (pc … st) ;
     76  ! frms ← opt_to_res ? [MSG FrameErrorOnPush] (st_frms … st);
     77  return
     78  (set_frms ERTL_state
     79  (〈\fst (regs ERTL_state st'),(pc_block (pc ? st))〉 :: frms)
     80    (set_regs ERTL_state 〈empty_map …,\snd (regs … st')〉 st')).
     81
     82
     83definition ertl_pop_frame:
     84 state ERTL_state →
     85   res (state ERTL_state × program_counter) ≝
     86 λst.
     87 ! frms ← opt_to_res ? [MSG FrameErrorOnPop] (st_frms … st);
     88 match frms with
     89 [ nil ⇒ Error ? [MSG FramesEmptyOnPop]
     90 | cons hd tl ⇒
     91   let 〈local_mem, bl〉 ≝ hd in
     92   let st' ≝ set_regs ERTL_state 〈local_mem, \snd (regs … st)〉
     93      (set_frms ERTL_state tl st) in
     94   ! 〈st'', pc〉 ← pop_ra … st' ;
     95   if eq_block bl (pc_block pc) then
     96     OK … 〈st'', pc〉
     97   else Error ? [MSG BlockInFramesCorrupted]
     98 ].
    7499
    75100(*CSC: XXXX, for external functions only*)
     
    85110  return (set_regs ERTL_state 〈\fst (regs … st), env'〉 st).*)
    86111
    87 axiom FunctionNotFound: errmsg.
    88 
    89112(*CSC: here we should use helper_def_store from Joint/semantics.ma,
    90113  but it is not visible *)
     
    95118  ! env' ← ps_reg_store dst v env ;
    96119  return set_regs ERTL_state env' st.
     120
     121axiom FunctionNotFound : errmsg.
    97122
    98123definition eval_ertl_seq:
     
    141166     λst.return map ?? (hwreg_retrieve (\snd (regs … st))) RegisterRets)
    142167  (* eval_ext_seq       ≝ *) (λgl,ge,stm,id.λ_.eval_ertl_seq F gl ge stm id)
    143   (* pop_frame          ≝ *) (λ_.λ_.λ_.λ_.pop_ra …).
     168  (* pop_frame          ≝ *) (λ_.λ_.λ_.λ_.ertl_pop_frame).
    144169
    145170definition ERTL_semantics ≝
  • src/ERTL/ERTLtoERTLptrOK.ma

    r2691 r2783  
    1414(**************************************************************************)
    1515
    16 include "ERTLptr/ERTLtoERTLptr.ma".
     16include "ERTL/ERTLToERTLptr.ma".
    1717include "common/StatusSimulation.ma".   
    1818include "joint/Traces.ma".
     
    2828joint_abstract_status (mk_prog_params ERTLptr_semantics prog stack_sizes).
    2929
    30 definition sigma_map ≝ λ prog : ertl_program.
    31 joint_closed_internal_function ERTL (prog_var_names … prog) → label → option label.
    32 
    33 
    34 definition sigma_pc_opt :
    35 ∀ prog : ertl_program.
    36 sigma_map prog → program_counter → option program_counter ≝
    37 λprog,sigma,pc.
    38   let ge ≝ globalenv_noinit … prog in
     30definition sigma_map ≝  block → label → option label.
     31definition lbl_funct ≝  block → label → option (list label).
     32definition regs_funct ≝ block → label → option (list register).
     33 (*
     34definition get_internal_function_from_ident :
     35∀ p: sem_params. ∀ globals : list ident . ∀ge : genv_t (joint_function p globals).
     36ident → option(joint_closed_internal_function p globals) ≝
     37λp,globals,ge,id.
     38! bl  ← (find_symbol (joint_function p globals) ge id);
     39! bl' ← (code_block_of_block bl);
     40! 〈f,fn〉 ← res_to_opt … (fetch_internal_function ? ge bl');
     41return fn.
     42*)
     43
     44lemma match_reg_elim : ∀ A : Type[0]. ∀ P : A → Prop. ∀ r : region.
     45∀f : (r = XData) → A. ∀g : (r = Code) → A. (∀ prf : r = XData.P (f prf)) →
     46(∀ prf : r = Code.P (g prf)) →
     47P ((match r return λx.(r = x → ?) with
     48    [XData ⇒ f | Code ⇒ g])(refl ? r)).
     49#A #P * #f #g #H1 #H2 normalize nodelta [ @H1 | @H2]
     50qed.
     51
     52(*
     53lemma get_internal_function_from_ident_ok :
     54∀p : sem_params. ∀globals : list ident. ∀ge : genv_t (joint_function p globals).
     55∀bl,f,fn. fetch_internal_function ? ge bl = return 〈f,fn〉 →
     56get_internal_function_from_ident p globals ge f= return fn.
     57#p #globals #ge #bl #f #fn #EQf
     58@('bind_inversion EQf) * #f1 * #fn1 whd in match fetch_function;
     59normalize nodelta #H lapply(opt_eq_from_res ???? H) -H #H @('bind_inversion H) -H
     60#f2 #EQf2 #H @('bind_inversion H) -H #fn2 #EQfn2 whd in ⊢ (??%% → ??%% → ?);
     61#EQ1 #EQ2 destruct whd in match get_internal_function_from_ident; normalize nodelta
     62>(symbol_of_block_rev … EQf2) >m_return_bind
     63cut(code_block_of_block bl = return bl)
     64 [ whd in match code_block_of_block; normalize nodelta @match_reg_elim
     65   [ >(pi2 ?? bl) #ABS destruct] elim bl #bl1 #EQ #prf % ] #EQbl >EQbl
     66>m_return_bind >EQf %
     67qed.
     68*)
     69
     70definition get_sigma :
     71ertl_program → lbl_funct → sigma_map ≝
     72λprog,f_lbls.λbl,searched.
     73let globals ≝ prog_var_names … prog in
     74let ge ≝ globalenv_noinit … prog in
     75! bl ← code_block_of_block bl ;
     76! 〈id,fn〉 ← res_to_opt … (fetch_internal_function … ge bl);
     77!〈res,s〉 ← find ?? (joint_if_code … fn)
     78                (λlbl.λ_. match f_lbls bl lbl with
     79                          [None ⇒ false
     80                          |Some lbls ⇒
     81                             match split_on_last … lbls with
     82                                [None ⇒ eq_identifier … searched lbl
     83                                |Some x ⇒ eq_identifier … searched (\snd x)
     84                                ]
     85                          ]);
     86return res.
     87
     88definition sigma_pc_opt : 
     89ertl_program →  lbl_funct →
     90program_counter → option program_counter ≝
     91λprog,f_lbls,pc.
     92  let sigma ≝ get_sigma prog f_lbls in
     93  let ertl_ptr_point ≝ point_of_pc ERTLptr_semantics pc in
    3994  if eqZb       (block_id (pc_block pc)) (-1) then (* check for dummy exit pc *)
    4095    return pc
    4196  else
    42     ! 〈i, fd〉 ← res_to_opt … (fetch_internal_function … ge (pc_block pc)) ;
    43     ! ertl_ptr_point ← sigma fd (point_of_pc ERTL_semantics pc) ;
    44     return pc_of_point
    45     ERTLptr_semantics (pc_block pc) ertl_ptr_point.
     97       ! ertl_point ← sigma (pc_block pc) ertl_ptr_point;
     98       return pc_of_point
     99                   ERTL_semantics (pc_block pc) ertl_point.
    46100
    47101definition sigma_stored_pc ≝
    48 λprog,sigma,pc. match sigma_pc_opt prog sigma pc with
     102λprog,f_lbls,pc. match sigma_pc_opt prog f_lbls pc with
    49103      [None ⇒ null_pc (pc_offset … pc) | Some x ⇒ x].
    50104     
    51105     
    52 definition sigma_beval :
    53  ∀prog : ertl_program.
    54   sigma_map prog →
     106definition sigma_beval : ertl_program → lbl_funct →
    55107  beval → beval ≝
    56 λprog,sigma,bv.
     108λprog,f_lbls,bv.
    57109match bv with
    58 [ BVpc pc prt ⇒ match sigma_pc_opt prog sigma pc with
     110[ BVpc pc prt ⇒ match sigma_pc_opt prog f_lbls pc with
    59111                 [None ⇒ BVundef | Some x ⇒ BVpc x prt]
    60112| _ ⇒ bv
    61113].
    62114
    63 (*
    64 definition sigma_beval :
    65  ∀prog,sigma,bv.
    66  sigma_beval_opt prog sigma bv ≠ None ? → beval ≝
    67  λprog,sigma,bv.opt_safe ….
    68 *)
    69 definition sigma_is :
    70  ∀prog : ertl_program.
    71   sigma_map prog →
    72   internal_stack → internal_stack ≝
    73 λprog,sigma,is.
     115definition sigma_is : ertl_program → lbl_funct →
     116internal_stack → internal_stack ≝
     117λprog,f_lbls,is.
    74118match is with
    75119[ empty_is ⇒ empty_is
    76 | one_is bv ⇒ one_is (sigma_beval prog sigma bv)
     120| one_is bv ⇒ one_is (sigma_beval prog f_lbls bv)
    77121| both_is bv1 bv2 ⇒
    78   both_is (sigma_beval prog sigma bv1) (sigma_beval prog sigma bv2)
     122  both_is (sigma_beval prog f_lbls bv1) (sigma_beval prog f_lbls bv2)
    79123].
    80124
    81125lemma sigma_is_empty : ∀prog,sigma.
    82126  sigma_is prog sigma empty_is = empty_is.
    83 #prog #sigma %
    84 qed.
    85 
    86 definition sigma_mem :
    87  ∀prog : ertl_program . sigma_map prog → bemem → bemem ≝
    88  λprog,sigma,m.
     127#prog #sigma % qed.
     128
     129definition sigma_mem : ertl_program → lbl_funct →
     130 bemem → bemem ≝
     131 λprog,f_lbls,m.
    89132 mk_mem
    90133  (λb.
     
    94137      mk_block_contents l h
    95138      (λz.If Zleb l z ∧ Zltb z h then with prf'' do
    96         sigma_beval prog sigma (contents (blocks m b) z)
     139        sigma_beval prog f_lbls (contents (blocks m b) z)
    97140      else BVundef)
    98141    else empty_block OZ OZ)
     
    100143  (nextblock_pos m).
    101144
    102 (*DOPPIONE ASSIOMA IN LINEARISE_PROOF.MA *)
    103 axiom mem_ext_eq :
    104   ∀m1,m2 : mem.
    105   (∀b.let bc1 ≝ blocks m1 b in
    106       let bc2 ≝ blocks m2 b in
    107       low bc1 = low bc2 ∧ high bc1 = high bc2 ∧
    108       ∀z.contents bc1 z = contents bc2 z) →
    109   nextblock m1 = nextblock m2 → m1 = m2.
    110 
    111 
    112 
    113 inductive id_is_in (A : Type[0]) : Pos →  positive_map A → Prop ≝
    114 | is_in_root : ∀l,r,opt_a. id_is_in A (one) (pm_node … opt_a l r)
    115 | is_in_left : ∀l,r,opt_a,x. id_is_in A x l →
    116                                     id_is_in A (p0 x) (pm_node … opt_a l r)
    117 | is_in_right : ∀l,r,opt_a,x. id_is_in A x r →
    118                                     id_is_in A (p1 x) (pm_node … opt_a l r).
    119 
    120 definition id_is_in : ∀A : Type[0]. ∀tag : identifierTag.
    121 identifier_map tag A → identifier tag → Prop ≝
    122 λA,tag,m,id.match id with
    123      [an_identifier x ⇒ match m with
    124                               [an_id_map p ⇒ id_is_in A x p]
    125      ].
    126      
    127 lemma lookup_eq : ∀ A : Type[0].
    128 ∀m,m' : positive_map A.
    129 (∀id. lookup_opt A id m = lookup_opt A id m'
    130       ∧ (id_is_in A id m ↔ id_is_in A id m')) → m=m'.
    131 #A #m elim m
    132 [ * [#_ %] #opt_a #l #r #H lapply(H one) normalize * #EQ >EQ * #_ #H1 lapply(H1 ?) [%]
    133   -H1 -H <EQ -EQ #H inversion H #l1 #r1 #opt_a1
    134   [ #_ #EQ  lapply(jmeq_to_eq ??? EQ) -EQ #EQ destruct(EQ)
    135   |*: #pos #H1 #_ #_ #EQ  lapply(jmeq_to_eq ??? EQ) -EQ #EQ destruct(EQ)
    136   ]
    137 | #opt_a #l #r #Hl #Hr *
    138   [ #H lapply(H one) normalize * #EQ >EQ * #H1 #_ lapply(H1 ?) [%]
    139   -H1 -H -EQ #H inversion H #l1 #r1 #opt_a1
    140     [ #_ #EQ  lapply(jmeq_to_eq ??? EQ) -EQ #EQ destruct(EQ)
    141     |*: #pos #H1 #_ #_ #EQ  lapply(jmeq_to_eq ??? EQ) -EQ #EQ destruct(EQ)
    142     ]
    143   | #opt_a1 #l1 #r1 #H lapply(H one) normalize * #EQ >EQ -EQ #_ @eq_f2 [@Hl|@Hr]
    144     #id [ lapply(H (p0 id)) | lapply(H (p1 id))] normalize * #H1 * #H2 #H3 %
    145     [1,3: assumption] % #H4 [1,3: lapply(H2 ?) |*: lapply(H3 ?)]
    146     try %2 try %3 try assumption #H5 inversion H5 #l2 #r2 #opt_a2
    147     [1,4,7,10: #EQ lapply(jmeq_to_eq ??? EQ) -EQ #EQ @⊥
    148                [1,3: cut(p0 id ≠ one) [1,3: @(pos_elim … id) /3/]
    149                |*:   cut(p1 id ≠ one) [1,3: @(pos_elim … id) /3/]
    150                ] * #H @H assumption
    151     |*: #pos #H6 #_ #EQ lapply(jmeq_to_eq ??? EQ) -EQ #EQ destruct(EQ)
    152         #EQ lapply(jmeq_to_eq ??? EQ) -EQ #EQ destruct(EQ) #_ assumption
    153     ]
    154   ]
    155 ]
    156 qed.
    157 
    158 include alias "common/Identifiers.ma".
    159 include alias "common/PositiveMap.ma".
    160 
    161 
    162 lemma p0_neq_one : ∀x: Pos. p0 x ≠ one.
    163 #x /3/
    164 qed.
    165 
    166 lemma p1_neq_one : ∀x: Pos. p1 x ≠ one.
    167 #x /3/
    168 qed.
    169 
    170 lemma lookup_ok_to_update : ∀ A : Type[0].
    171 ∀ tag : identifierTag.
    172 ∀m,m' : identifier_map tag A. ∀id,a.
    173 (lookup tag A m' id = Some ? a)  → lookup tag A m id ≠ None ? →
    174 (∀ id'. id ≠ id' → (lookup tag A m id' = lookup tag A m' id') ∧
    175      (id_is_in A tag m id' ↔ id_is_in A tag m' id')) →
    176 update tag A m id a = return m'.
    177 #A #tag * #m * #m' * #id #a
    178 normalize in ⊢ (%→%→?); lapply id -id lapply m' -m' elim m
    179     [ #m' #id #m_spec' normalize in ⊢ (% → ?); * #EQ @⊥ @EQ %] #opt_a #l #r #Hl #Hr
    180     #m' * [|*: #x] normalize in ⊢ (%→%→?); #m_spec'
    181     [ cases opt_a -opt_a [* #H @⊥ @H %] #a1 #_ #H normalize @eq_f @eq_f
    182       lapply H -H lapply m_spec'; -m_spec' lapply a -a cases m'
    183       [#a normalize #EQ destruct] #opt_a1 #l1 #r1 #a
    184       normalize in ⊢ (%→?); #EQ >EQ #H @eq_f2 @lookup_eq #id'
    185       [ lapply (H (an_identifier tag (p0 id')) ?)
    186       | lapply (H (an_identifier tag (p1 id')) ?)
    187       ]
    188       [1,3:% @(pos_elim … id') [1,3:#H destruct|*: #n #IP #H destruct]]
    189       * normalize #H1 * #H2 #H3 % [1,3: >H1 %] % #H4
    190       [1,3: lapply(H2 ?) |*: lapply(H3 ?)] try %2 try %3 try assumption
    191       #H5 inversion H5 #l2 #r2 #opt_a2
    192         [1,4,7,10: #EQ lapply(jmeq_to_eq ??? EQ) -EQ #EQ @⊥
    193                    [1,3: cut(p0 id' ≠ one) [1,3: /3/]
    194                    |*: cut(p1 id' ≠ one) [1,3: /3/]
    195                    ] >EQ * #H @H %
    196         |*: #pos #H6 #_ #EQ1 lapply(jmeq_to_eq ??? EQ1) -EQ1 #EQ1 destruct(EQ1)
    197             #EQ1 lapply(jmeq_to_eq ??? EQ1) -EQ1 #EQ1 destruct(EQ1) #_ assumption
    198         ]
    199     |*: #H lapply m_spec' -m_spec' cases m' -m' [1,3: normalize #EQ destruct]
    200         #opt_a1 #l1 #r1 normalize in ⊢ (% → ?); #H1 #H2
    201         [ lapply(Hr ?? H1 H ?) | lapply(Hl ?? H1 H ?)]
    202           [1,3: * #y * #y_spec
    203             [lapply(H2 (an_identifier tag (p1 y)) ?) | lapply(H2 (an_identifier tag (p0 y)) ?)]
    204             [1,3: % #EQ destruct @y_spec %] * normalize #H3 * #H4 #H5 % // % #H6
    205             [1,3: lapply(H4 ?) |*: lapply (H5 ?)] try %2 try %3 try assumption
    206             #H7 inversion H7 #l2 #r2 #opt_a2
    207               [1,4,7,10: #EQ lapply(jmeq_to_eq ??? EQ) -EQ #EQ @⊥
    208                    [1,3: cut(p1 y ≠ one) [1,3: /3/]
    209                    |*: cut(p0 y ≠ one) [1,3: /3/]
    210                    ] >EQ * #H @H %
    211               |*: #pos #H6 #_ #EQ1 lapply(jmeq_to_eq ??? EQ1) -EQ1 #EQ1
    212                  destruct(EQ1) #EQ1 lapply(jmeq_to_eq ??? EQ1) -EQ1 #EQ1
    213                  destruct(EQ1) #_ assumption
    214               ]
    215           |2,4: normalize cases(update A x a ?) normalize [2,4: #pos_map]
    216                #EQ destruct @eq_f @eq_f lapply(H2 (an_identifier tag one) ?)
    217                [1,3: % #EQ destruct] * normalize #EQ >EQ #_ @eq_f2 [2,3: %]
    218                @lookup_eq #id'
    219                [lapply (H2 (an_identifier tag (p0 id')) ?) |
    220                                    lapply (H2 (an_identifier tag (p1 id')) ?) ]
    221                [1,3: % #EQ1 destruct] * normalize #H3 * #H4 #H5 % // % #H6
    222                [1,3: lapply(H4 ?) |*: lapply(H5 ?)] try %2 try %3 try assumption
    223                #H7 inversion H7 #l2 #r2 #opt_a2
    224                   [1,4,7,10: #EQ lapply(jmeq_to_eq ??? EQ) -EQ #EQ @⊥
    225                     [1,3: cut(p0 id' ≠ one) [1,3: /3/]
    226                     |*: cut(p1 id' ≠ one) [1,3: /3/]
    227                    ] >EQ * #H @H %
    228                   |*: #pos #H6 #_ #EQ1 lapply(jmeq_to_eq ??? EQ1) -EQ1 #EQ1
    229                       destruct(EQ1) #EQ1 lapply(jmeq_to_eq ??? EQ1) -EQ1 #EQ1
    230                       destruct(EQ1) #_ assumption
    231                   ]
    232             ]
    233       ]
    234 qed.
    235 
    236 lemma update_ok_to_lookup : ∀ A : Type[0].
    237 ∀ tag : identifierTag.
    238 ∀m,m' : identifier_map tag A. ∀id,a.
    239 update tag A m id a = return m' →
    240 (lookup tag A m' id = Some ? a) ∧ lookup tag A m id ≠ None ? ∧
    241 (∀ id'. id ≠ id' → (lookup tag A m id' = lookup tag A m' id') ∧
    242      (id_is_in A tag m id' ↔ id_is_in A tag m' id')).
    243 #A #tag * #m * #m' * #id #a
    244 whd in ⊢ (??%% →  ?); inversion(update A ???) normalize nodelta [#_ #ABS destruct]
    245     #m1 #m1_spec #EQ destruct % [%]
    246     [  normalize @(update_lookup_opt_same … m1_spec)
    247     |3: * #id' * #id_spec' normalize %
    248         [@(update_lookup_opt_other … m1_spec ??) % #EQ @id_spec' >EQ %]
    249         lapply id_spec' lapply m1_spec -id_spec' -m1_spec
    250         (*cases id [|*:#x] -id normalize*) lapply m' -m' lapply id lapply id' -id -id'
    251         elim m [#id' #id #m' cases id [|*: #x] normalize #EQ destruct]
    252         #opt_a #l #r #Hl #Hr #id' #id #m' cases id [|*:#x] -id normalize
    253         [ cases opt_a [2:#a] normalize #EQ destruct cases id' [#H @⊥ @H %]
    254           #x #_ normalize % #H [1,2: %3 |*: %2]
    255           inversion H #l1 #r1 #opt_a1
    256           [1,4,7,10: #EQ lapply(jmeq_to_eq ??? EQ) #EQ1 @⊥
    257                      [1,2: cut(p1 x ≠ one) [1,3: @(pos_elim … x) /3/]
    258                      |*:   cut(p0 x ≠ one) [1,3: @(pos_elim … x) /3/]
    259                      ]
    260                      * #H @H >EQ1 //   
    261           |*:        #pos #H1 #_ #EQ lapply(jmeq_to_eq ??? EQ) #EQ1 destruct(EQ1)
    262                      #EQ lapply(jmeq_to_eq ??? EQ) #EQ1 destruct(EQ1) #_ assumption
    263           ]
    264         |*: inversion(update A x a ?) normalize [1,3: #_ #EQ destruct] #pos_map
    265             #pos_map_spec #EQ destruct #id_spec' % #H
    266             inversion H #l1 #l2 #opt_a1
    267             [1,4,7,10: #EQ lapply(jmeq_to_eq ??? EQ) -EQ #EQ
    268                        #EQ1 lapply(jmeq_to_eq ??? EQ1) -EQ1 #EQ1 destruct(EQ1)
    269                        #H1 %
    270             |*: #pos #H1 #_ #EQ lapply(jmeq_to_eq ??? EQ) -EQ #EQ
    271                 #EQ1 lapply(jmeq_to_eq ??? EQ1) -EQ1 #EQ1 destruct(EQ1)
    272                 #H2 try %2 try %3 try assumption
    273                 [ @(proj1 … (Hr ? ? pos_map pos_map_spec ?)) [#EQ1 destruct @id_spec' %]
    274                 | @(proj2 … (Hr ? ? l2 pos_map_spec ?)) [#EQ1 destruct @id_spec' %]
    275                 | @(proj1 … (Hl ? ? pos_map pos_map_spec ?)) [#EQ1 destruct @id_spec' %]
    276                 | @(proj2 … (Hl ? ? l1 pos_map_spec ?)) [#EQ1 destruct @id_spec' %]
    277                 ]
    278                 assumption
    279             ]
    280          ]     
    281     | % normalize lapply m1_spec lapply id lapply m' -id -m' elim m
    282       [#m' * [|*: #x] normalize #EQ destruct] #opt_a #l #r #Hl #Hr #m' * [|*: #x]
    283       normalize [ cases opt_a [2:#a] normalize #EQ1 #EQ2 destruct]
    284       inversion (update A x a ?) [1,3: #_ normalize #EQ destruct]
    285       #pos_map #EQpos_map normalize #EQ destruct [@Hr|@Hl] assumption
    286     ]
    287 qed.
    288 
    289 
    290 (*
    291                
    292 lemma update_lookup_after : ∀ A : Type[0].
    293 ∀ tag : identifierTag.
    294 ∀m,m' : identifier_map tag A. ∀id,a.
    295 update tag A m id a = return m' →
    296 lookup tag A m' id = Some ? a.
    297 #A #B #tag * #m1 * #id #a whd in ⊢ (??%% → ?); inversion(update A ???)
    298 normalize nodelta [#_ #EQ destruct] #pos_map #pos_map_spec #EQ destruct
    299 @(update_lookup_opt_same … pos_map_spec)
    300 qed.
    301 
    302 lemma p0_neq_one : ∀x: Pos. p0 x ≠ one.
    303 #x /3/
    304 qed.
    305 
    306 lemma p1_neq_one : ∀x: Pos. p1 x ≠ one.
    307 #x /3/
    308 qed.
    309 
    310 lemma id_is_in_map : ∀ A,B : Type[0]. ∀tag : identifierTag.
    311 ∀m : identifier_map tag A.
    312 ∀ F : (∀a:A.(Σid. lookup tag A m id = Some A a) → B).
    313 ∀id. id_is_in A tag m id ↔ id_is_in B tag (map_inf1 A B tag m F) id.
    314 #A #B #tag * #m elim m
    315 [ #F * #id % normalize #H inversion H #l #r #opt_a
    316   [1,4: #_ #EQ lapply(jmeq_to_eq ??? EQ) -EQ #EQ destruct
    317   |*: #pos #H1 #_ #_ #EQ lapply(jmeq_to_eq ??? EQ) -EQ #EQ destruct
    318   ]
    319 | * [2:#a] #l #r #Hl #Hr #F ** [1,4: |*:#x] normalize % #H try % try %2 try %3
    320   [1,2,5,6: cases(Hr ? (an_identifier tag x)) |*: cases (Hl ? (an_identifier tag x))]
    321   [2,4,6,8,10,12,14,16: #a1 ** #id1 #prf1 @F try(@a1)
    322                         try(%{(an_identifier tag (p1 id1))} assumption)
    323                         try(%{(an_identifier tag (p0 id1))} assumption) ]
    324   try(#H1 #_ @H1) try(#_ #H1 @H1) -H1 -Hl -Hr inversion H #l1 #r1 #opt_a1
    325   [1,4,7,10,13,16,19,22: #EQ lapply(jmeq_to_eq ??? EQ) -EQ #EQ @⊥
    326              [1,2,3,4: lapply(p1_neq_one x)
    327              |*:       lapply(p0_neq_one x)
    328              ] * #H @H >EQ %
    329   |*: #pos #H1 #_ #EQ lapply(jmeq_to_eq ??? EQ) -EQ #EQ destruct
    330       #EQ lapply(jmeq_to_eq ??? EQ) -EQ #EQ destruct #_ assumption
    331   ]
    332 ]
    333 qed.
    334 
    335 lemma map_update_commute : ∀ A, B : Type[0].
    336 ∀tag : identifierTag.
    337 ∀m1,m2 : identifier_map tag A.
    338 ∀id,a.
    339 update tag A m1 id a = return m2 →
    340 ∀ F : (∀a:A.(Σid. lookup tag A m1 id = Some A a) → B).
    341 ∀ F': (∀a:A.(Σid. lookup tag A m2 id = Some A a) → B). 
    342 (∀a',id',prf,prf'. F a' «id',prf» = F' a' «id',prf'») → ∃prf.
    343 update tag B (map_inf1 A B tag m1 F) id (F' a «id,prf») =
    344 return map_inf1 A B tag m2 F'.
    345 #A #B #tag #m1 #m2 #id #a #m2_spec #F #F' #eqFF' %
    346 [ @hide_prf cases(update_lookup_previous A tag m1 m2 id a) #H1 #_ cases (H1 m2_spec)
    347   * #H1 #H2 #H3 assumption
    348 | cases(update_lookup_previous B tag (map_inf1 A B tag m1 F)
    349                              (map_inf1 A B tag m2 F') id (F' a «id,?»))
    350   [ #_ #H @H |] cases(update_lookup_previous A tag m1 m2 id a) #H2 #INUTILE
    351 cases(H2 m2_spec) * #H3 #H4 #H5 % [%]
    352 [ >(lookup_map … H3) %
    353 | elim H4 -H4 #H4 % #H5 @H4 lapply H5 cases m1 in F; -m1 #m1 cases id -id
    354   elim m1 [ #id #F normalize * %] #a1 #l #r #Hl #Hr * [|*:#x] #F normalize
    355   [ cases a1 in F; [2: #a2] #F normalize [2: * %] #EQ destruct
    356   |*: #H
    357     [@(Hr x ??) | @(Hl x ??)]
    358     [1,3:#a ** #id1 #prf1 @F [1,3: @a]
    359          [%{(an_identifier tag (p1 id1))}|%{(an_identifier tag (p0 id1))}]
    360          normalize assumption
    361     |*: normalize @H
    362     ]
    363   ]
    364 | #id' #id_spec' lapply(H5 id' id_spec') * #H6 * #H7 #H8 %
    365   [ lapply H6 inversion (lookup tag A m2 id')
    366     [2: #w] #w_spec #EQ >(lookup_map … EQ) normalize nodelta
    367     >(lookup_map … w_spec) normalize nodelta [2: %] @eq_f @eqFF'
    368   | cases(id_is_in_map A B tag m1 F id') cases(id_is_in_map A B tag m2 F' id')
    369    #H9 #H10 #H11 #H12 % #H13 [ @H9 @H7 @H12 assumption | @H11 @H8 @H10 assumption]
    370   ]
    371 ]
    372 qed.
    373 
    374 (*
    375 definition well_formed_register_env :
    376 ∀prog : ertl_program .∀sigma : (sigma_map prog).
    377 register_env beval → Prop ≝
    378 λprog,sigma,psd_reg.∀id,bv. lookup ?? psd_reg id = Some ? bv →
    379 sigma_beval_opt prog sigma bv ≠ None ?.
    380 *)
    381 *)
    382 
    383 definition map : ∀tag,A,B. identifier_map tag A → (A → B) → identifier_map tag B ≝
    384 λtag,A,B,m,f.match m with
    385 [an_id_map p ⇒ an_id_map … (map ?? f p)].
    386 
    387 lemma lookup_map : ∀A,B : Type[0].
    388   ∀tag : identifierTag.
    389   ∀m : identifier_map tag A.
    390   ∀ f:A → B.
    391   ∀ id.
    392 lookup tag B (map tag A B m f) id =
    393 ! a ← lookup tag A m id; return f a.
    394 #A #B #tag * #m #f * #id normalize >lookup_opt_map %
    395 qed.
    396 
    397 lemma update_leaf_fail: ∀tag,A,i,v.
    398  update tag A (empty_map ??) i v = Error ? [MSG MissingId; CTX … i].
    399 #ta #A ** [|*: #x] #v normalize %
    400 qed.
    401 
    402 lemma update_def : ∀tag,A,m,i,v.
    403   update tag A m i v =
    404   match lookup tag A m i with
    405   [ Some _ ⇒ OK ? (add tag A m i v)
    406   | None ⇒ Error ? [MSG MissingId; CTX … i]
    407   ].
    408 #tag #A #m #i #v inversion(update tag A m i v)
    409 [ #m' #EQm' cases(update_ok_to_lookup ?????? EQm') * #_
    410  #H #_ elim H cases(lookup tag A m i) [#H @⊥ @H %]
    411  #x #_ normalize <EQm' lapply EQm' cases i cases m cases m' -m -m' -i
    412  normalize #m' #m #i inversion(update A i v m) normalize [#_ #ABS destruct]
    413  #m'' #EQm'' #EQ destruct(EQ) @eq_f @eq_f lapply EQm'' -EQm'' lapply i -i
    414  lapply m' -m' elim m [#m' * [2,3: #z] normalize #EQ destruct]
    415  #opt_a #l #r #Hl #Hr #m' * [2,3: #z] normalize
    416  [3: cases opt_a normalize [2: #y] #EQ destruct %
    417  |*: inversion(update A z v ?) [2,4: #m'']  #EQm'' normalize #EQ destruct
    418      [<(Hr … EQm'') | <(Hl … EQm'')] %
    419  ]
    420 | #err cases m -m cases i -i #i #m normalize inversion(update A i v m) [2:#m']
    421   #EQerr normalize #EQ destruct lapply EQerr lapply i elim m
    422   [ normalize #x #_ %] #opt_a #l #r #Hl #Hr * [2,3:#z] normalize
    423  [3: cases opt_a [2:#w] normalize #EQ destruct %
    424  |*: inversion(update A z v ?) [2,4: #m'] #EQm' normalize #EQ destruct
    425      [lapply(Hr … EQm') | lapply(Hl … EQm')] cases(lookup_opt A z ?) [2,4: #a]
    426      normalize #EQ destruct %
    427  ]
    428 ]
    429 qed.
    430 
    431 lemma map_add : ∀tag : identifierTag.∀A,B : Type[0].∀ f: A → B.∀m,id,v.
    432 map tag A B (add tag A m id v) f = add tag B (map tag A B m f) id (f v).
    433 #tag #A #B #f * #m * #id #v normalize @eq_f lapply v -v lapply id -id elim m
    434 [ #id elim id [#v %] #x #IH #id normalize >IH normalize inversion(pm_set ? ? ? ?)
    435   normalize // cases x normalize [2,3,5,6: #y] #EQ destruct
    436 | #opt_a #l #r #Hl #Hr * [2,3: #x| #v normalize cases opt_a normalize [2: #a %]
    437   cases (map_opt ? ? ? l) normalize [2: //] cases (map_opt ? ? ? r) normalize
    438   //] #v normalize cases opt_a [2,4: #a] normalize //
    439   [ cases(map_opt ? ? ? l) normalize // >Hr cases(map_opt ? ? ? r) normalize
    440     [2: #opt_b #lb #rb] inversion(pm_set B x ? ?) normalize // cases x [2,3,5,6: #y]
    441     normalize #EQ destruct
    442   | >Hl cases(map_opt ? ? ? l) normalize [2: #opt_b #lb #rb]
    443     inversion (pm_set B x ? ?) normalize //
    444     [1,2: cases x [2,3,5,6: #y] normalize #EQ destruct]
    445     #opt_b' #lb' #rb' #_ normalize #_ #EQ cases(map_opt ? ? ? r)
    446     normalize nodelta [%] #opt_b'' #lb'' #rb'' >EQ %
    447 ]
    448 qed.
    449 
    450 
    451 definition restrict : ∀tag.∀A,B.
    452 identifier_map tag A → identifier_map tag B → identifier_map tag A ≝
    453 λtag,A,B,m1,m2.an_id_map …
    454            (merge A B A (λo,o'.match o' with [None ⇒ None ? | Some _ ⇒ o])
    455                   (match m1 with [an_id_map p1 ⇒ p1])
    456                   (match m2 with [an_id_map p2 ⇒ p2])).
    457 
    458 interpretation "identifier map restriction" 'intersects a b = (restrict ??? a b).
    459 
    460 unification hint 0 ≔ tag ; R ≟ identifier tag ⊢ list R ≡ list (identifier tag).
    461  
    462 lemma map_update_commute : ∀tag : identifierTag.∀A,B : Type[0].∀f : A → B. ∀m,id,v.
    463 update tag B (map tag A B m f) id (f v) =
    464 !m' ← update tag A m id v; return map tag A B m' f.
    465 #tag #A #B #f #m #id #v >update_def >update_def >lookup_map
    466 cases (lookup tag A m id) [%] #a >m_return_bind >m_return_bind normalize nodelta
    467 whd in ⊢ (???%); @eq_f @sym_eq @map_add
    468 qed.
    469 
    470 definition is_leaf ≝ λA.λpm : positive_map A.
    471 match pm with [ pm_leaf ⇒ true | _ ⇒ false ].
    472 (*
    473 let rec pm_clean A (pm : positive_map A) on pm : positive_map A ≝
    474 match pm with
    475 [ pm_leaf ⇒ pm_leaf ?
    476 | pm_node o l r ⇒
    477   let l' ≝ pm_clean … l in
    478   let r' ≝ pm_clean … r in
    479   match o with
    480   [ Some _ ⇒ pm_node … o l' r'
    481   | None ⇒
    482     if is_leaf … l' ∧ is_leaf … r' then pm_leaf ? else
    483     pm_node … o l' r'
    484   ]
    485 ].
    486  
    487 definition clean ≝ λtag,A.λm : identifier_map tag A.
    488   match m with [ an_id_map pm ⇒ an_id_map tag A (pm_clean … pm) ].
    489 *)
     145include "common/ExtraIdentifiers.ma".
     146
    490147
    491148definition sigma_register_env :
    492 ∀prog : ertl_program.∀sigma : (sigma_map prog).
    493 register_env beval → list register →  register_env beval ≝
    494 λprog,sigma,psd_env,ids.
    495 let m' ≝  map ??? psd_env (λbv.sigma_beval prog sigma bv) in
     149ertl_program → lbl_funct →
     150list register →
     151register_env beval → register_env beval ≝
     152λprog,f_lbls,ids,psd_env.
     153let m' ≝  map ??? psd_env (λbv.sigma_beval prog f_lbls bv) in
    496154m' ∖ ids.
    497155
    498 (*
    499 definition well_formed_ertl_psd_env :
    500 ∀prog : ertl_program. ∀sigma : (sigma_map prog).
    501 ertl_psd_env → Prop≝
    502 λprog,sigma,psd_env.well_formed_register_env prog sigma (psd_regs psd_env).
    503 *)
    504 (*
    505 let rec well_formed_frames
    506 (prog : ertl_program) (sigma : (sigma_map prog))
    507 (l : list ertl_psd_env) on l : Prop ≝
    508 match l with
    509   [nil ⇒ True
    510   | cons a tl ⇒ well_formed_ertl_psd_env prog sigma a ∧
    511                well_formed_frames prog sigma tl
    512   ].                           
    513 *)
    514 
    515 
    516 lemma lookup_restrict : ∀tag,A,B.∀a : identifier_map tag A.∀b : identifier_map tag B.
    517 ∀i.lookup ?? (a ∩ b) i = if i ∈ b then lookup … a i else None ?.
    518 #tag #A #B * #a * #b * #i normalize >lookup_opt_merge [2: %] cases (lookup_opt B i b)
    519 [2: #b] normalize % qed.
    520 
    521 
    522 lemma lookup_set_minus : ∀tag,A,B. ∀a : identifier_map tag A. ∀b : identifier_map tag B.
    523 ∀i. lookup ?? (a ∖ b) i = if i ∈ b then None ? else lookup … a i.
    524 #tag #A #B * #a * #b * #i normalize >lookup_opt_merge [2: %] cases(lookup_opt B i b)
    525 [2: #b] % qed.
    526 
    527 (*
    528 lemma clean_add : ∀tag,A,m,i,v.clean … (add tag A m i v) = add tag A (clean … m) i v.
    529 #tag #A * #m * #i #v normalize @eq_f
    530 lapply m -m
    531 elim i -i
    532 [ * [%]
    533   * [2: #x] #l #r [%] normalize
    534   cases (pm_clean A l) normalize // cases (pm_clean A r) //
    535 |*: #i #IH * normalize
    536   [1,3: >IH cases i // ]
    537   * [2,4: #x] #l #r normalize
    538   [1,2: >IH % ]
    539   >IH cases i cases (pm_clean A l) cases (pm_clean A r) normalize //
    540 ]
    541 qed.
    542 
    543 lemma clean_lookup : ∀tag,A,m,i.lookup … (clean tag A m) i = lookup … m i.
    544 #tag #A * #m * #i normalize lapply i -i elim m
    545 [#i %] * [2: #a] #l #r #Hl #Hr * [2,3,5,6: #x] normalize in ⊢ (???%);
    546 [1,3:<Hr|2,4:<Hl] normalize try % [3: @if_elim #_ %]
    547 cases(pm_clean A l) in Hl; normalize
    548 [2: #opt_a1 #l1 #r1 #_ %
    549 |3: #H cases(pm_clean A r) normalize //
    550 | #H cases(pm_clean A r) in Hr; normalize //
    551 | #opt_a1 #l1 #r1 #H cases x normalize //
    552 ]
    553 qed.   
    554 
    555  
    556 lemma clean_update : ∀tag,A,m,i,v.
    557 ! m' ← update tag A m i v; return clean … m' =
    558 update tag A (clean … m) i v.
    559 #tag #A #m #i #v
    560 >update_def >update_def >clean_lookup cases (lookup tag A m i)
    561 [ % ]
    562 #m' >m_return_bind normalize nodelta >clean_add %
    563 qed.
    564 *)
    565 lemma lookup_eq_id_map : ∀tag : identifierTag. ∀ A : Type[0].
    566 ∀m,m' : identifier_map tag A.
    567 (∀id. lookup … m id = lookup … m' id
    568       ∧ (id_is_in A tag m id ↔ id_is_in A tag m' id)) → m=m'.
    569 #tag #A * #m * #m' #H @eq_f @lookup_eq #id lapply(H (an_identifier tag id))
    570 * #H1 #H2 % // assumption
    571 qed.
    572 
    573 (*
    574 lemma clean_leaf : ∀tag : identifierTag . ∀ A : Type[0].
    575 ∀m : identifier_map tag A. (∀ id. lookup … m id = None ?) →
    576 clean ?? m = empty_map ??.
    577 #tag #A * #m elim m [#_ %] #opt_a #l #r #Hl #Hr #H normalize @eq_f
    578 lapply(H (an_identifier tag one)) normalize #EQ >EQ -EQ normalize
    579 lapply(Hl ?) [2: lapply(Hr ?)]
    580   [1,3: * #id [lapply(H (an_identifier tag (p1 id))) | lapply(H (an_identifier tag (p0 id)))]
    581        #H assumption
    582   | normalize #EQ #EQ1 destruct >e0 >e1 normalize %
    583   ]
    584 qed.
    585 *)
    586 lemma id_is_in_lookup : ∀tag,A,m,id,v.
    587  lookup tag A m id = Some ? v → id_is_in A tag m id.
    588 #tag #A * #m * #id #a normalize lapply m -m elim id
    589 [|*: #x #IH] * normalize [1,3,5: #EQ destruct] #opt_a #l #r [ #_ %] #H [%3 |%2]
    590 @IH assumption
    591 qed.
    592 (*
    593 lemma pm_clean_leaf : ∀ A : Type[0].
    594 ∀m : positive_map A. (∀ id. lookup_opt … id m = None ?) →
    595 pm_clean ? m = pm_leaf ….
    596 #A #m elim m [ #id %] #opt_a #l #r #Hl #Hr #H normalize lapply(H one) normalize
    597 #EQ >EQ normalize >Hl [normalize >Hr [ %]] #id [@(H (p1 id))|@(H (p0 id))]
    598 qed.
    599 
    600 
    601 lemma pm_clean_canonic : ∀A,m,n.(∀i.lookup_opt A i m = lookup_opt A i n) →
    602   pm_clean ? m = pm_clean ? n.
    603 #A #m #n lapply m -m elim n
    604 [ @pm_clean_leaf ]
    605 * [2: #x] #l #r #IHl #IHr *
    606   [1,3: #H @sym_eq @pm_clean_leaf #id @sym_eq @H ] #opt #l' #r' #H
    607  lapply (H one) normalize in ⊢ (%→?); #EQ destruct
    608  whd in ⊢ (??%%);
    609  >(IHl l') [1,3: >(IHr r') [1,3 : % ]] #i
    610  [1,2: @(H (p1 i)) |*: @(H (p0 i)) ] qed.
    611 
    612 
    613 lemma clean_canonic : ∀tag,A,m,n.(∀i.lookup tag A m i = lookup tag A n i) →
    614   clean ?? m = clean ?? n.
    615 #tag #A * #m * #n #H normalize @eq_f @pm_clean_canonic #i
    616 lapply(H (an_identifier tag i))
    617 normalize //
    618 qed.
    619 *)
    620 lemma update_fail_lookup : ∀tag,A,m,i,v,e.update tag A m i v = Error … e → 
    621   e = [MSG MissingId; CTX … i] ∧ lookup … m i = None ?.
    622 #tag #A #m #i #v #errmsg >update_def cases(lookup tag A m i) [2: #a] normalize
    623 #EQ destruct % //
    624 qed.
    625 
    626 lemma lookup_hit_update : ∀tag,A,m,i,v.i ∈ m → 
    627   ∃m'.update tag A m i v = OK ? m'.
    628 #tag #A #m #i #v #H % [2: >update_def lapply(in_map_domain … m i) >H * #v #EQ >EQ
    629 normalize %|]
    630 qed.
    631 
    632 lemma lookup_miss_update : ∀tag,A,m,i,v.lookup tag A m i = None ? → 
    633   update … m i v = Error … [MSG MissingId; CTX … i].
    634 #tag #A #m #i #v #EQ >update_def >EQ normalize %
    635 qed.
    636 
    637 lemma update_ok_old_lookup : ∀tag,A,m,i,v,m'.update tag A m i v = OK ? m' →
    638   i ∈ m.
    639 #tag #A #m #i #v #m' >update_def inversion(lookup tag A m i) [2: #a] #EQ normalize
    640 #EQ destruct >EQ normalize @I
    641 qed.
    642 
    643 lemma lookup_update_ok : ∀tag,A,m,i,v,m',i'.update tag A m i v = OK ? m' →
    644   lookup … m' i' = if eq_identifier ? i' i then Some ? v else lookup … m i'.
    645 #tag #A #m #i #v #m' #i' >update_def inversion(lookup tag A m i) [2: #a] #EQ
    646 normalize nodelta #EQ1 destruct @eq_identifier_elim
    647 [ #H normalize nodelta >H @lookup_add_hit
    648 | #H normalize nodelta @lookup_add_miss assumption
    649 ]
    650 qed.
    651 
    652 lemma mem_set_restrict : ∀tag,A,B.∀a : identifier_map tag A.∀b : identifier_map tag B.
    653 ∀i.i ∈ a ∩ b = (i ∈ a ∧ i ∈ b).
    654 #tag #A #B * #a * #b  * #i normalize >lookup_opt_merge [2: %] cases(lookup_opt B i b)
    655 [2: #a1] normalize [2: @if_elim #_ %] cases(lookup_opt A i a) [2: #a2] normalize %
    656 qed.
    657 (*
    658 lemma merge_eq : ∀A.∀p : positive_map A.∀choice. merge
    659 *)
    660 (*
    661 lemma add_restrict : ∀tag,A,B.∀a : identifier_map tag A. ∀b : identifier_map tag B.
    662 ∀i,v.i∈b → add tag A (a ∩ b) i v = (add tag A a i v) ∩ b.
    663 #tag #A #B * #a * #b * #i #v normalize inversion(lookup_opt B i b) normalize [#_ *]
    664 #v1 #EQv1 * @eq_f lapply EQv1 lapply v1 lapply a lapply b -a -b -v1 elim i normalize
    665 [ * normalize [#b #v #EQ destruct] #opt_a #l #r *
    666   [#v #EQ destruct normalize %] #opt_b #l1 #r1 #v #EQ destruct normalize cases opt_b
    667   normalize [2: #x %] cases(merge A B A ? l1 l) normalize [2: #opt_a2 #l2 #r2 %]
    668   cases(merge A B A ? r1 r) //
    669 |*: #x #IH * [2,4: #opt_b #l1 #r1] #p1 normalize [3,4: #i #EQ destruct] cases p1 -p1
    670     [2,4: #opt_a #l2 #r2] normalize #v #H cases opt_b [2,4,6,8: #b] normalize
    671     [1,2,5,6: <IH try assumption [1,2: cases opt_a [2,4: #a] normalize try %]
    672      cases(merge A B A ? l2 l1) normalize // lapply H [1,4: cases r1 |*: cases l1]
    673      normalize [1,3,5,7,9,11: #EQ destruct] #opt_b4 #l4 #r4 cases x normalize
    674      [1,4,7,10,13,16: #EQ destruct normalize // cases(merge A B A ? ? ?) normalize //]
    675      #x #H normalize cases(merge A B A ? ? ?) normalize //
    676     |*: <IH try assumption
    677        [1,3: cases(map_opt ? ? ? l1) normalize // lapply H cases r1 normalize
    678             [1,3: #EQ destruct] #opt_b2 #l2 #r2 cases x [1,4: //] #x normalize //
    679        |*: lapply H cases x normalize [2,3,5,6: #y] cases l1 normalize
    680           [1,3,5,7,9,11: #EQ destruct] #opt_b2 #l2 #r2 #H //
    681        ]
    682    ]
    683 ]
    684 qed.
    685 
    686 lemma update_restrict : ∀tag,A,B.∀a : identifier_map tag A.∀b : identifier_map tag B.
    687 ∀i,v.i ∈ b → update ?? (a ∩ b) i v =
    688   ! a' ← update ?? a i v ; return a' ∩ b.
    689 #tag #A #B #a #b #id #v #H
    690 lapply (in_map_domain … b id) >H * #ignore #EQ_lookup_b
    691 (*<clean_update*)
    692 inversion (update tag A a id v)
    693 [2: #e #EQ cases (update_fail_lookup ?????? EQ) #EQ1 #EQ2 destruct
    694   >lookup_miss_update [%]
    695   >lookup_restrict >H assumption ]
    696 #m' #EQ >m_return_bind
    697 cases (lookup_hit_update ?? (a∩b) id v ?)
    698 [2: >mem_set_restrict >H >(update_ok_old_lookup ?????? EQ) % ]
    699 #m'' >update_def >update_def in EQ; >lookup_restrict >H normalize nodelta
    700 cases(lookup tag A a id) normalize nodelta [#ABS destruct] #v1 #EQ #EQ'' destruct
    701 whd in ⊢ (??%%); @eq_f @add_restrict assumption
    702 qed.
    703 *)
    704 lemma add_set_minus  : ∀tag,A,B.∀a : identifier_map tag A.∀b : identifier_map tag B.
    705 ∀i,v.¬(i ∈ b) → add tag A (a ∖ b) i v = (add tag A a i v) ∖ b.
    706 #tag #A #B * #a * #b * #i #v @notb_elim @if_elim normalize [#_ *]
    707 @if_elim [2: #_ *] @if_elim [#_ *] inversion(lookup_opt B i b) normalize [2: #x #_ *]
    708 #H * * * * @eq_f lapply H -H lapply v -v lapply b -b lapply a -a elim i
    709 [  *
    710   [ * [2: #opt_b #l #r] #v normalize in ⊢ (% → ?); #EQ destruct [2: %]
    711   normalize in ⊢ (??%%); cases (map_opt ??? l) // normalize cases(map_opt ??? r)
    712   normalize //
    713   | * [2: #a] #l #r * [2,4: #opt_b #l1 #r1] #v normalize in ⊢ (% → ?); #EQ destruct
    714     normalize [3: % |1,2: cases(merge ???? l l1) // cases(merge ???? r r1) //]
    715     cases(map_opt ??? l) normalize // cases(map_opt ??? r) //
    716   ]
    717 |2,3: #x #IH * [2,4: #opt_a #l #r] * [2,4,6,8: #opt_b #l1 #r1] #v
    718       normalize in ⊢ (% → ?); #H whd in match (pm_set ????) in ⊢ (???%);
    719       whd in match (merge ??????) in ⊢ (???%);
    720       [1,2,3,4: <IH try assumption whd in match (pm_set ????) in ⊢ (??%?);
    721                 whd in match (merge ??????) in ⊢ (??%?); cases opt_b normalize
    722                 [2,4,6,8: #b] [5,6: cases opt_a normalize //]
    723                 [1,2,3,4: cases (merge ???? l l1) normalize [2,4,6,8: #opt_a2 #l2 #r2]
    724                           // cases (merge ???? r r1) normalize
    725                           [2,4,6,8,10,12: #opt_a3 #l3 #r3] inversion(pm_set ????)
    726                           normalize // cases x
    727                           [2,3,5,6,8,9,11,12,14,15,17,18,20,21,23,24 : #y]
    728                           normalize #EQ destruct
    729                 |*: cases(map_opt ??? l1) normalize [2,4,6,8: #opt_a2 #l2 #r2] //
    730                     cases(map_opt ??? r1) normalize [2,4,6,8,10,12: #opt_a3 #l3 #r3]
    731                     inversion(pm_set ????) normalize // cases x
    732                     [2,3,5,6,8,9,11,12,14,15,17,18,20,21,23,24 : #y]
    733                     normalize #EQ destruct
    734                 ]
    735      |*: whd in match (pm_set ????) in ⊢ (??%?);
    736          whd in match (merge ??????) in ⊢ (??%?); [1,2: cases opt_a [2,4: #a]]
    737          normalize
    738          [1,2: @eq_f2 [1,4:%] | cases(map_opt ??? l) [2: #opt_a1 #l1 #r1] normalize
    739          | cases(map_opt ??? r) [2: #opt_a1 #l1 #r1] normalize]       
    740          [1,3,4: lapply(map_add tag A A (λx.x) (an_id_map … r) (an_identifier ? x) v)
    741          |2,5,6: lapply(map_add tag A A (λx.x) (an_id_map … l) (an_identifier ? x) v)
    742          |*: lapply(map_add tag A A (λx.x) (an_id_map … (pm_leaf ?)) (an_identifier ? x) v)
    743          ] normalize #EQ destruct >e0 try % [4,5: cases x [2,3,5,6: #y] normalize %]
    744            cases(map_opt ????) [2,4,6: #opt_a1 #l1 #r1] normalize
    745            inversion(pm_set ????) normalize // cases x [2,3,5,6,8,9,11,12: #y]
    746            normalize #EQ1 destruct
    747      ]
    748 ]
    749 qed.     
    750 
    751 lemma update_set_minus : ∀tag,A,B.∀a : identifier_map tag A.∀b : identifier_map tag B.
    752 ∀i,v.¬(i ∈ b) → update ?? (a ∖ b) i v =
    753   ! a' ← update ?? a i v ; return a' ∖ b.
    754 #tag #A #B #a #b #id #v #H >update_def >lookup_set_minus @if_elim
    755 [ #H1 @⊥ lapply H1 lapply H @notb_elim >H1 normalize *] #_ >update_def
    756 cases (lookup tag A a id) normalize [ %] #a @eq_f @add_set_minus assumption
    757 qed.
    758 
    759 
    760 record good_state_transformation
    761 (prog : ertl_program)
    762 (def_in : joint_closed_internal_function ERTL (prog_var_names ?? prog)) :
    763 Type[0] ≝
    764 { f_lbls : label → option (list label)
    765 ; f_regs : label → option (list register)
    766 ; part_partition_f_lbls : partial_partition … f_lbls
    767 ; part_partion_f_regs : partial_partition … f_regs
    768 ; freshness_lab : let def_out ≝ translate_internal … def_in in
    769      (∀l.opt_All … (All …
    770     (λlbl.¬fresh_for_univ … lbl (joint_if_luniverse … def_in) ∧
    771            fresh_for_univ … lbl (joint_if_luniverse … def_out))) (f_lbls l))
    772 ; freshness_regs : let def_out ≝ translate_internal … def_in in
    773   (∀l.opt_All … (All …
    774     (λreg.¬fresh_for_univ … reg (joint_if_runiverse … def_in) ∧
    775            fresh_for_univ … reg (joint_if_runiverse … def_out))) (f_regs l))
    776 ; multi_fetch_ok : let def_out ≝ translate_internal … def_in in
    777   let f_step ≝ translate_step ? in
    778   let f_fin ≝  translate_fin_step ? in
    779   ∀l,s.stmt_at … (joint_if_code … def_in) l = Some ? s →
    780   ∃lbls,regs.f_lbls l = Some ? lbls ∧ f_regs l = Some ? regs ∧
    781   match s with
    782   [ sequential s' nxt ⇒
    783     l ~❨f_step l s', lbls, regs❩~> nxt in joint_if_code … def_out
    784   | final s' ⇒
    785     l ~❨f_fin l s', lbls, regs❩~> it in joint_if_code … def_out
    786   | FCOND abs _ _ _ ⇒ Ⓧabs
    787   ]
    788 }.
    789 
    790 definition get_internal_function_from_ident :
    791 ∀ p: sem_params. ∀ globals : list ident . ∀ge : genv_t (joint_function p globals).
    792 ident → option (joint_closed_internal_function p globals) ≝
    793 λp,globals,ge,id.
    794 ! bl  ← (find_symbol (joint_function p globals) ge id);
    795 ! bl' ← (code_block_of_block bl);
    796 ! 〈f,fn〉 ← res_to_opt … (fetch_internal_function ? ge bl');
    797 return fn.
    798 
    799 definition get_sigma_from_good_state :
    800 ∀prog : ertl_program.
    801 (∀ fn : joint_closed_internal_function ERTL (prog_var_names ?? prog).
    802 good_state_transformation prog fn) → sigma_map prog ≝
    803 λprog,good,fn,searched.
    804 !〈res,s〉 ← find ?? (joint_if_code … fn)
    805                 (λlbl.λ_. match (f_lbls … (good fn)) lbl with
    806                           [None ⇒ false
    807                           |Some lbls ⇒
    808                              match lbls with
    809                                 [nil ⇒ eq_identifier … searched lbl
    810                                 |cons hd tl ⇒ let last ≝ last_ne … «hd::tl,I» in
    811                                           eq_identifier … searched last
    812                                 ]
    813                           ]);
    814 return res.
    815 
    816 
    817 definition sigma_frames : ∀prog : ertl_program.
    818 (∀fn.good_state_transformation prog fn) →
    819 list (register_env beval × ident) → (list (register_env beval × ident)) ≝
    820 λprog,good,frms.
    821 let sigma ≝ get_sigma_from_good_state … good in
    822 foldr ??
    823 (λx,tl.let 〈reg_env,id〉 ≝ x in
    824        match get_internal_function_from_ident
    825                   ERTL_semantics (prog_var_names … prog)
    826                   (globalenv_noinit … prog) id with
    827        [Some fn ⇒
    828   〈(sigma_register_env prog sigma reg_env
    829        (added_registers … fn (f_regs … (good fn)))),id〉 :: tl
    830        |None ⇒ [ ]
    831        ]) ([ ]) frms.
    832 
    833 
    834 (*
    835 lemma sigma_empty_frames_commute :
    836 ∀prog : ertl_program. ∀ sigma : (sigma_map prog).
    837 ∃prf.
    838 sigma_frames prog sigma [] prf = [].
    839 #p #s % normalize %
    840 qed.
    841 
    842 
    843 let rec sigma_bit_vector_trie_opt (prog : ertl_program)
    844 (sigma : (sigma_map prog)) (n : nat) (t : BitVectorTrie beval n)
    845 on t : option … (BitVectorTrie beval n) ≝
    846 match t with
    847   [Leaf bv ⇒ ! bv' ← (sigma_beval_opt prog sigma bv);
    848                    return Leaf … bv'
    849   |Node n1 b1 b2 ⇒ ! b1' ← (sigma_bit_vector_trie_opt prog sigma n1 b1);
    850                    ! b2' ← (sigma_bit_vector_trie_opt prog sigma n1 b2);
    851                    return Node … n1 b1' b2'
    852   |Stub n1 ⇒  return Stub … n1
    853   ].
    854 
    855 
    856 definition well_formed_hw_register_env :
    857 ∀ prog : ertl_program. ∀ sigma : (sigma_map prog).
    858 hw_register_env → Prop ≝
    859 λprog,sigma,regs.sigma_bit_vector_trie_opt prog sigma 6 (reg_env … regs) ≠ None ?.
    860 *)
    861 
    862 
     156
     157definition sigma_frames_opt : ertl_program →
     158lbl_funct → regs_funct →
     159list (register_env beval × (Σb:block.block_region b=Code)) →
     160option (list (register_env beval × (Σb:block.block_region b=Code))) ≝
     161λprog,f_lbls,f_regs,frms.
     162let globals ≝ prog_var_names … prog in
     163let ge ≝ globalenv_noinit … prog in
     164m_list_map ? ? ?
     165(λx.let 〈reg_env,bl〉 ≝ x in
     166    ! 〈id,fn〉 ← res_to_opt … (fetch_internal_function … ge bl);
     167    return 〈sigma_register_env prog f_lbls
     168                (added_registers ERTL globals fn (f_regs bl)) reg_env,bl〉) frms.
     169               
     170definition sigma_frames :   ertl_program →
     171lbl_funct → regs_funct →
     172option (list (register_env beval × (Σb:block.block_region b=Code))) →
     173option (list (register_env beval × (Σb:block.block_region b=Code))) ≝
     174λprog,f_lbls,f_regs,frms.
     175! frames ← frms;
     176sigma_frames_opt prog f_lbls f_regs frames.
     177       
    863178include "common/BitVectorTrieMap.ma".
    864179
    865 definition sigma_hw_register_env :
    866 ∀prog: ertl_program. ∀sigma : (sigma_map prog).
    867 hw_register_env → hw_register_env ≝
    868 λprog,sigma,h_reg.mk_hw_register_env
    869 (map ? ? (sigma_beval prog sigma) 6 (reg_env … h_reg)) (other_bit … h_reg).
    870 
    871 
    872 definition sigma_regs :
    873 ∀prog : ertl_program. ∀sigma : (sigma_map prog).
    874 (register_env beval)×hw_register_env→ list register →
     180definition sigma_hw_register_env :ertl_program →
     181lbl_funct →  hw_register_env → hw_register_env ≝
     182λprog,f_lbls,h_reg.mk_hw_register_env
     183(map ? ? (sigma_beval prog f_lbls) 6 (reg_env … h_reg)) (other_bit … h_reg).
     184
     185definition sigma_regs :ertl_program →
     186lbl_funct →  list register →
     187(register_env beval)×hw_register_env→
    875188(register_env beval)×hw_register_env ≝
    876 λprog,sigma,regs,ids.let 〈x,y〉≝ regs in
    877       〈sigma_register_env prog sigma x ids,
    878        sigma_hw_register_env prog sigma y〉.
    879 (*
    880 lemma sigma_empty_regsT_commute :
    881 ∀prog : ertl_program. ∀sigma : (sigma_map prog).
    882 ∀ptr.∃ prf.
    883   empty_regsT ERTLptr_semantics ptr =
    884   sigma_regs prog sigma (empty_regsT ERTL_semantics ptr) prf.
    885 #prog #sigma #ptr %
    886 [ @hide_prf whd in match well_formed_regs; normalize nodelta %
    887  [whd in match well_formed_ertl_psd_env; normalize nodelta #id #bv
    888   normalize in ⊢ (%→?); #EQ destruct
    889  | normalize % #EQ destruct
    890  ]
    891 | % ]
    892 qed.
    893 
    894 axiom sigma_load_sp_commute :
    895 ∀prog : ertl_program.∀sigma : (sigma_map prog).
    896 ∀regs,ptr.
    897 load_sp ERTL_semantics regs = return ptr
    898 → ∃prf.
    899 load_sp ERTLptr_semantics (sigma_regs prog sigma regs prf) = return ptr.
    900 
    901 axiom sigma_save_sp_commute :
    902 ∀prog : ertl_program. ∀sigma : (sigma_map prog).
    903 ∀reg,ptr,prf1. ∃prf2.
    904 save_sp ERTLptr_semantics (sigma_regs prog sigma reg prf1) ptr =
    905 sigma_regs prog sigma (save_sp ERTL_semantics reg ptr) prf2.
    906 
    907 definition well_formed_state :
    908 ∀prog : ertl_program. ∀sigma : sigma_map prog.
    909 state ERTL_semantics → Prop ≝
    910 λprog,sigma,st.
    911 well_formed_frames prog sigma (st_frms … st) ∧
    912 sigma_is_opt prog sigma (istack … st) ≠ None ? ∧
    913 well_formed_regs prog sigma (regs … st) ∧
    914 well_formed_mem prog sigma (m … st).
    915 *)
    916 
    917 definition sigma_state : ∀prog : ertl_program.
    918 (∀fn.good_state_transformation prog fn) →
    919  state ERTLptr_semantics → list register →
    920  state ERTL_semantics ≝
    921 λprog,good,st,ids.
    922 let sigma ≝ get_sigma_from_good_state … good in
    923 mk_state ?
    924   (sigma_frames prog good (st_frms ERTLptr_semantics st))
    925   (sigma_is ? sigma (istack … st))
    926   (carry … st)
    927   (sigma_regs ? sigma (regs … st) ids)
    928   (sigma_mem ? sigma (m … st)).
    929 
     189λprog,f_lbls,ids,regs.let 〈x,y〉≝ regs in
     190      〈sigma_register_env prog f_lbls ids x,
     191       sigma_hw_register_env prog f_lbls y〉.
    930192
    931193definition dummy_state : state ERTL_semantics ≝
    932194mk_state ERTL_semantics
    933    [ ] empty_is BBundef 〈empty_map ? ?,mk_hw_register_env … (Stub …) BBundef〉 empty.
     195   (None ?) empty_is BBundef 〈empty_map ? ?,mk_hw_register_env … (Stub …) BBundef〉 empty.
     196
     197definition sigma_state : ertl_program →
     198lbl_funct → regs_funct → list register →
     199state ERTLptr_semantics → state ERTL_semantics ≝
     200λprog,f_lbls,f_regs,restr,st.
     201mk_state ERTL_semantics
     202  (sigma_frames prog f_lbls f_regs (st_frms ERTLptr_semantics st))
     203  (sigma_is prog f_lbls (istack … st))
     204  (carry … st)
     205  (sigma_regs prog f_lbls restr (regs … st))
     206  (sigma_mem prog f_lbls (m … st)).
    934207   
    935208definition dummy_state_pc : state_pc ERTL_semantics ≝
    936209mk_state_pc ? dummy_state (null_pc one) (null_pc one).
    937210
    938 definition sigma_state_pc :
    939 ∀prog : ertl_program.
    940 (∀fn.good_state_transformation prog fn) →
    941 state_pc ERTLptr_semantics →
    942  state_pc ERTL_semantics ≝
    943 λprog,good,st.
    944   let sigma ≝ get_sigma_from_good_state … good in
    945   let ge ≝ globalenv_noinit … prog in
    946   if eqZb       (block_id (pc_block (pc … st))) (-1) then (* check for dummy pc *)
    947     dummy_state_pc
    948   else
    949   match (fetch_internal_function (joint_closed_internal_function ERTL
    950          (prog_var_names (joint_function ERTL) ℕ prog)) ge (pc_block (pc … st))) with
    951    [OK x ⇒ let 〈i,fd〉 ≝ x in
    952       mk_state_pc ?
    953        (sigma_state prog good st (added_registers … fd (f_regs … (good fd))))
    954        (pc … st) (sigma_stored_pc prog sigma (last_pop … st))
    955    |Error msg ⇒ dummy_state_pc].
    956 
    957 
    958 definition ERTLptrStatusSimulation :
    959 ∀ prog : ertl_program.
    960 let trans_prog ≝ ertl_to_ertlptr prog in
    961 ∀stack_sizes.(∀fn.good_state_transformation prog fn) →
    962 status_rel (ERTL_status prog stack_sizes) (ERTLptr_status trans_prog stack_sizes) ≝
    963 λprog,stack_sizes,good.
    964   let trans_prog ≝ ertl_to_ertlptr prog in
    965     mk_status_rel ??
    966     (* sem_rel ≝ *) (λs1:ERTL_status prog stack_sizes
    967        .λs2:ERTLptr_status trans_prog stack_sizes
    968         .s1=sigma_state_pc prog good s2)
    969     (* call_rel ≝ *) 
    970           (λs1:Σs:ERTL_status prog stack_sizes
    971                .as_classifier (ERTL_status prog stack_sizes) s cl_call
    972        .λs2:Σs:ERTLptr_status trans_prog stack_sizes
    973                 .as_classifier (ERTLptr_status trans_prog stack_sizes) s cl_call
    974         .let sigma ≝ get_sigma_from_good_state … good in
    975         pc (mk_prog_params ERTL_semantics prog stack_sizes) s1
    976          =sigma_stored_pc prog sigma
    977           (pc
    978            (mk_prog_params ERTLptr_semantics (ertl_to_ertlptr prog) stack_sizes)
    979            s2))
    980     (* sim_final ≝ *) ?.
    981 cases daemon
    982 qed.
    983 
    984 lemma fetch_function_no_minus_one :
    985   ∀F,V,i,p,bl.
    986   block_id (pi1 … bl) = -1 →
    987   fetch_function … (globalenv (λvars.fundef (F vars)) V i p)
    988     bl = Error … [MSG BadFunction].
    989  #F#V#i#p ** #r #id #EQ1 destruct
    990   whd in match fetch_function; normalize nodelta
    991   >globalenv_no_minus_one
    992   cases (symbol_for_block ???) normalize //
    993 qed.
    994  
    995 lemma fetch_function_no_zero :
    996  ∀F,V,i,p,bl.
    997   block_id (pi1 … bl) = 0 →
    998   fetch_function … (globalenv (λvars.fundef (F vars)) V i p)
    999     bl = Error … [MSG BadFunction].
    1000  #F#V#i#p ** #r #id #EQ1 destruct
    1001   whd in match fetch_function; normalize nodelta
    1002   >globalenv_no_zero
    1003   cases (symbol_for_block ???) normalize //
    1004 qed.
    1005 
    1006 (*DOPPIONI dei LEMMI in LINEARISE_PROOF*)
    1007 lemma symbol_for_block_match:
    1008     ∀M:matching.∀initV,initW.
    1009      (∀v,w. match_var_entry M v w →
    1010       size_init_data_list (initV (\snd v)) = size_init_data_list (initW (\snd w))) →
    1011     ∀p: program (m_A M) (m_V M). ∀p': program (m_B M) (m_W M).
    1012     ∀MATCH:match_program … M p p'.
    1013     ∀b: block.
    1014     symbol_for_block … (globalenv … initW p') b =
    1015     symbol_for_block … (globalenv … initV p) b.
    1016 * #A #B #V #W #match_fn #match_var #initV #initW #H
    1017 #p #p' * #Mvars #Mfn #Mmain
    1018 #b
    1019 whd in match symbol_for_block; normalize nodelta
    1020 whd in match globalenv in ⊢ (???%); normalize nodelta
    1021 whd in match (globalenv_allocmem ????);
    1022 change with (add_globals ?????) in match (foldl ?????);
    1023 >(proj1 … (add_globals_match … initW … Mvars))
    1024 [ % |*:]
    1025 [ * #idr #v * #idr' #w #MVE %
    1026   [ inversion MVE
    1027     #H1 #H2 #H3 #H4 #H5 #H6 #H7 #H8 destruct %
    1028   | @(H … MVE)
    1029   ]
    1030 | @(matching_fns_get_same_blocks … Mfn)
    1031   #f #g @match_funct_entry_id
    1032 ]
    1033 qed.
    1034 
    1035 lemma symbol_for_block_transf :
    1036  ∀A,B,V,init.∀prog_in : program A V.
    1037  ∀trans : ∀vars.A vars → B vars.
    1038  let prog_out ≝ transform_program … prog_in trans in
    1039  ∀bl.
    1040  symbol_for_block … (globalenv … init prog_out) bl =
    1041  symbol_for_block … (globalenv … init prog_in) bl.
    1042 #A #B #V #iV #p #tf @(symbol_for_block_match … (transform_program_match … tf ?))
    1043 #v0 #w0 * //
    1044 qed.
    1045 
    1046 lemma fetch_function_transf :
    1047  ∀A,B,V,init.∀prog_in : program A V.
    1048  ∀trans : ∀vars.A vars → B vars.
    1049  let prog_out ≝ transform_program … prog_in trans in
    1050  ∀bl,i,f.
    1051  fetch_function … (globalenv … init prog_in) bl =
    1052   return 〈i, f〉
    1053 → fetch_function … (globalenv … init prog_out) bl =
    1054   return 〈i, trans … f〉.
    1055 #A #B #V #init #prog_in #trans #bl #i #f
    1056  whd in match fetch_function; normalize nodelta
    1057  #H lapply (opt_eq_from_res ???? H) -H
    1058  #H @('bind_inversion H) -H #id #eq_symbol_for_block
    1059  #H @('bind_inversion H) -H #fd #eq_find_funct
    1060  whd in ⊢ (??%?→?); #EQ destruct(EQ)
    1061  >(symbol_for_block_transf … trans) >eq_symbol_for_block >m_return_bind
    1062  >(find_funct_ptr_transf A B …  eq_find_funct) %
    1063 qed.
    1064 
    1065 
    1066 lemma fetch_internal_function_transf :
    1067  ∀A,B.∀prog_in : program (λvars.fundef (A vars)) ℕ.
    1068  ∀trans : ∀vars.A vars → B vars.
    1069  let prog_out ≝ transform_program … prog_in (λvars.transf_fundef … (trans vars)) in
    1070  ∀bl,i,f.
    1071  fetch_internal_function … (globalenv_noinit … prog_in) bl =
    1072   return 〈i, f〉
    1073 → fetch_internal_function … (globalenv_noinit … prog_out) bl =
    1074   return 〈i, trans … f〉.
    1075 #A #B #prog #trans #bl #i #f
    1076  whd in match fetch_internal_function; normalize nodelta
    1077  #H @('bind_inversion H) * #id * #fd normalize nodelta #EQfetch
    1078  whd in ⊢ (??%%→?); #EQ destruct(EQ)
    1079  >(fetch_function_transf … EQfetch) %
    1080 qed.
    1081 
    1082 (*
    1083 definition good_local_sigma :
    1084   ∀globals.
    1085   ∀g:codeT ERTLptr globals.
    1086   (Σl.bool_to_Prop (code_has_label … g l)) →
    1087   codeT ERTL globals →
    1088   (label → option label) → Prop ≝
    1089   λglobals,g,c,sigma.
    1090     ∀l,l'.sigma l = Some ? l' →
    1091       ∃s. stmt_at … g l = Some ? s ∧
    1092           All ? (λl.sigma l ≠ None ?) (stmt_labels … s) ∧
    1093           (match s with
    1094            [ sequential s' nxt ⇒
    1095              match s' with
    1096              [ step_seq _ ⇒
    1097                (stmt_at … c n = Some ? (sequential … s' it)) ∧
    1098                   ((sigma nxt = Some ? (S n)) ∨
    1099                    (stmt_at … c (S n) = Some ? (GOTO … nxt)))
    1100              | COND a ltrue ⇒
    1101                (stmt_at … c n = Some ? (sequential … s' it) ∧ sigma nxt = Some ? (S n)) ∨
    1102                (stmt_at … c n = Some ? (FCOND … I a ltrue nxt))
    1103              ]
    1104            | final s' ⇒
    1105              stmt_at … c n = Some ? (final … s')
    1106            | FCOND abs _ _ _ ⇒ Ⓧabs
    1107            ]).
    1108  
    1109 *)
     211definition sigma_state_pc : ertl_program → lbl_funct → regs_funct →
     212state_pc ERTLptr_semantics → state_pc ERTL_semantics ≝
     213λprog,f_lbls,f_regs,st.
     214let ge ≝ globalenv_noinit … prog in
     215let globals ≝ prog_var_names … prog in
     216match fetch_internal_function … ge (pc_block (pc … st)) with
     217  [ OK y ⇒ let 〈i,fn〉 ≝ y in
     218           let added ≝ added_registers ERTL globals fn
     219                                          (f_regs (pc_block (pc … st))) in
     220           mk_state_pc ?
     221           (sigma_state prog f_lbls f_regs added st)
     222               (pc … st) (sigma_stored_pc prog f_lbls (last_pop … st))
     223  | Error e ⇒ dummy_state_pc
     224  ].
     225
    1110226
    1111227lemma ps_reg_retrieve_ok :  ∀prog : ertl_program.
    1112 sigma : sigma_map prog. ∀r,restr.
     228f_lbls : lbl_funct. ∀r,restr.
    1113229preserving1 ?? res_preserve1 …
    1114      (λregs.sigma_regs prog sigma regs restr)
    1115      (sigma_beval prog sigma)
     230     (sigma_regs prog f_lbls restr)
     231     (sigma_beval prog f_lbls)
    1116232     (λregs.ps_reg_retrieve regs r)
    1117233     (λregs.ps_reg_retrieve regs r).
    1118 #prog #sigma #r #restr * #psd_r #hw_r whd in match ps_reg_retrieve;
     234#prog #f_lbls #r #restr * #psd_r #hw_r whd in match ps_reg_retrieve;
    1119235whd in match reg_retrieve; normalize nodelta @opt_to_res_preserve1
    1120236whd in match sigma_regs; whd in match sigma_register_env; normalize nodelta
     
    1125241
    1126242lemma hw_reg_retrieve_ok : ∀prog : ertl_program.
    1127 sigma : sigma_map prog. ∀r,restr.
     243f_lbls : lbl_funct. ∀r,restr.
    1128244preserving1 ?? res_preserve1 …
    1129     (λregs.sigma_regs prog sigma regs restr)
    1130     (sigma_beval prog sigma)
     245    (sigma_regs prog f_lbls restr)
     246    (sigma_beval prog f_lbls)
    1131247    (λregs.hw_reg_retrieve regs r)
    1132248    (λregs.hw_reg_retrieve regs r).
    1133 #prog #sigma #r #restr * #psd_r * #hw_r #b whd in match hw_reg_retrieve;
     249#prog #f_lbls #r #restr * #psd_r * #hw_r #b whd in match hw_reg_retrieve;
    1134250whd in match hwreg_retrieve; normalize nodelta whd in match sigma_regs;
    1135251whd in match sigma_hw_register_env; normalize nodelta
    1136 change with (sigma_beval prog sigma BVundef) in ⊢ (???????(??(?????%))?);
     252change with (sigma_beval prog f_lbls BVundef) in ⊢ (???????(??(?????%))?);
    1137253#bv >lookup_map whd in ⊢ (???% → ?); #EQ destruct
    1138254%{(lookup beval 6 (bitvector_of_register r) hw_r BVundef)}
     
    1142258
    1143259lemma ps_reg_store_ok : ∀prog : ertl_program.
    1144 ∀sigma : sigma_map prog. ∀r,restr.
     260∀f_lbls : lbl_funct. ∀r,restr.
     261¬(r ∈ (set_from_list RegisterTag restr)) →
    1145262preserving21 ?? res_preserve1 …
    1146    (sigma_beval prog sigma)
    1147    (λregs.sigma_regs prog sigma regs restr)
    1148    (λregs.sigma_regs prog sigma regs restr)
     263   (sigma_beval prog f_lbls)
     264   (sigma_regs prog f_lbls restr)
     265   (sigma_regs prog f_lbls restr)
    1149266   (ps_reg_store r)
    1150267   (ps_reg_store r).
    1151 #prog #sigma #r #restr whd in match ps_reg_store; normalize nodelta
     268#prog #f_lbls #r #restr #Hreg whd in match ps_reg_store; normalize nodelta
    1152269#bv * #psd_r #hw_r @mfr_bind1
    1153 [ @(λr.sigma_register_env prog sigma r restr)
     270[ @(sigma_register_env prog f_lbls restr)
    1154271| whd in match reg_store; whd in match sigma_regs; normalize nodelta
    1155   #x #x_spec lapply(update_ok_to_lookup ?????? x_spec) * * #_ #EQpsd #_
     272  #x #x_spec %{(add RegisterTag beval psd_r r bv)} % // whd in x_spec : (???%);
     273  destruct whd in match sigma_register_env; normalize nodelta >map_add
     274  >add_set_minus [% | assumption]
     275| #z @mfr_return_eq1 %
     276qed. 
     277(* 
     278   lapply(update_ok_to_lookup ?????? x_spec) * * #_ #EQpsd #_
    1156279  lapply x_spec -x_spec lapply EQpsd -EQpsd whd in match sigma_register_env;
    1157280  normalize nodelta >lookup_set_minus @if_elim [ #_ * #H @⊥ @H %]
     
    1162285  whd in ⊢ (???% → ?); #EQ destruct %{〈x,hw_r〉} % //
    1163286]
    1164 qed.
     287qed.*)
    1165288
    1166289
    1167290lemma hw_reg_store_ok : ∀prog : ertl_program.
    1168 sigma : sigma_map prog. ∀r,restr.
     291f_lbls : lbl_funct. ∀r,restr.
    1169292preserving21 ?? res_preserve1 …
    1170    (sigma_beval prog sigma)
    1171    (λregs.sigma_regs prog sigma regs restr)
    1172    (λregs.sigma_regs prog sigma regs restr)
     293   (sigma_beval prog f_lbls)
     294   (sigma_regs prog f_lbls restr)
     295   (sigma_regs prog f_lbls restr)
    1173296   (hw_reg_store r)
    1174297   (hw_reg_store r).
    1175298#prog #sigma #r #restr whd in match hw_reg_store; normalize nodelta
    1176 #bv * #psd_r * #hw_r #b whd in match hwreg_store; whd in match sigma_regs; normalize nodelta
     299#bv * #psd_r * #hw_r #b whd in match hwreg_store; whd in match sigma_regs;
     300normalize nodelta
    1177301whd in match sigma_hw_register_env; normalize nodelta <insert_map * #psd_r'
    1178302* #hw_r' #b' whd in ⊢ (???% → ?); #EQ destruct % [2: % [%] % |]
    1179303qed.
    1180304
     305definition move_dst_not_fresh : list register →  move_dst → Prop ≝
     306λrestr,mv.match mv with
     307  [PSD r ⇒ bool_to_Prop (¬(r ∈ (set_from_list RegisterTag restr)))
     308  | _ ⇒ True
     309  ].
    1181310
    1182311lemma ertl_eval_move_ok : ∀prog : ertl_program.
    1183 ∀sigma : sigma_map prog. ∀ restr,pm.
     312∀f_lbls : lbl_funct. ∀ restr,pm.
     313move_dst_not_fresh restr (\fst pm) →
    1184314preserving1 ?? res_preserve1 …
    1185      (λregs.sigma_regs prog sigma regs restr)
    1186      (λregs.sigma_regs prog sigma regs restr)
     315     (sigma_regs prog f_lbls restr)
     316     (sigma_regs prog f_lbls restr)
    1187317     (λregs.ertl_eval_move regs pm)
    1188318     (λregs.ertl_eval_move regs pm).
    1189 #prog #sigma #restr * #mv_dst #arg_dst #pm whd in match ertl_eval_move;
     319#prog #sigma #restr * #mv_dst #arg_dst #Hpm #pm whd in match ertl_eval_move;
    1190320normalize nodelta @mfr_bind1 [@(sigma_beval prog sigma)
    1191321| cases arg_dst normalize nodelta
     
    1193323      @mfr_return1]
    1194324  * #r normalize nodelta [@ps_reg_retrieve_ok| @hw_reg_retrieve_ok]
    1195 | #bv cases mv_dst #r normalize nodelta [@ps_reg_store_ok | @hw_reg_store_ok]
     325| #bv cases mv_dst in Hpm; #r #Hpm normalize nodelta [@ps_reg_store_ok assumption
     326                                                     | @hw_reg_store_ok
     327                                                     ]
    1196328]
    1197329qed.
    1198330
    1199331lemma ps_arg_retrieve_ok : ∀prog : ertl_program.
    1200 sigma : sigma_map prog. ∀a,restr.
     332f_lbls : lbl_funct. ∀a,restr.
    1201333preserving1 ?? res_preserve1 …
    1202     (λregs.sigma_regs prog sigma regs restr)
    1203     (sigma_beval prog sigma)
     334    (sigma_regs prog f_lbls restr)
     335    (sigma_beval prog f_lbls)
    1204336    (λregs.ps_arg_retrieve regs a)
    1205337    (λregs.ps_arg_retrieve regs a).
     
    1213345
    1214346lemma pop_ok :
    1215 ∀prog : ertl_program.
    1216 ∀good : (∀fn.good_state_transformation prog fn).
    1217 ∀restr.
     347∀prog : ertl_program.∀f_lbls : lbl_funct.
     348∀f_regs : regs_funct.∀restr.
    1218349preserving1 ?? res_preserve1 ????
    1219    (λst.sigma_state prog good st restr)
     350   (sigma_state prog f_lbls f_regs restr)
    1220351   (λx.let 〈bv,st〉 ≝ x in
    1221       〈let sigma ≝ get_sigma_from_good_state … good in
    1222        sigma_beval prog sigma bv,
    1223        sigma_state prog good st restr〉)
     352      〈sigma_beval prog f_lbls bv,
     353       sigma_state prog f_lbls f_regs restr st〉)
    1224354   (pop ERTL_semantics)
    1225355   (pop ERTLptr_semantics).
    1226 #prog #good #restr whd in match pop; normalize nodelta #st @mfr_bind1
     356#prog #f_lbls #f_regs #id whd in match pop; normalize nodelta #st @mfr_bind1
    1227357[@(λx.let 〈bv,is〉 ≝ x in
    1228       let sigma ≝ get_sigma_from_good_state … good in
    1229      〈sigma_beval prog sigma bv,
    1230       sigma_is prog sigma is 〉)
    1231 | whd in match is_pop; normalize nodelta whd in match sigma_state; normalize nodelta
    1232   cases(istack ? st) normalize nodelta
     358     〈sigma_beval prog f_lbls bv,
     359      sigma_is prog f_lbls is 〉)
     360| whd in match is_pop; normalize nodelta whd in match sigma_state;
     361  normalize nodelta cases(istack ? st) normalize nodelta
    1233362  [@res_preserve_error1
    1234363  |2,3: #bv1 [2: #bv2] * #bv3 #is1 whd in ⊢ (??%% → ?); #EQ destruct
    1235364        % [2,4: % [1,3: %|*: %] |*:]
    1236365  ]
    1237 | * #bv #is * #bv1 #st whd in ⊢ (??%% → ?); #EQ destruct % [2: % [%] %|]
     366| * #bv #is normalize nodelta @mfr_return_eq1 %   
    1238367]
    1239368qed.
     
    1241370lemma push_ok :
    1242371∀prog : ertl_program.
    1243 good : (∀fn.good_state_transformation prog fn).
    1244 restr.
     372f_lbls : lbl_funct.
     373f_regs : regs_funct.∀restr.
    1245374preserving21 ?? res_preserve1 …
    1246      (λst.sigma_state prog good st restr)
    1247      (let sigma ≝ get_sigma_from_good_state … good in sigma_beval prog sigma)
    1248      (λst.sigma_state prog good st restr)
     375     (sigma_state prog f_lbls f_regs restr)
     376     (sigma_beval prog f_lbls)
     377     (sigma_state prog f_lbls f_regs restr)
    1249378     (push ERTL_semantics)
    1250379     (push ERTLptr_semantics).
    1251 #prog #good #restr whd in match push; normalize nodelta #st #bv @mfr_bind1
    1252 [ @(let sigma ≝ get_sigma_from_good_state … good in sigma_is ? sigma)
     380#prog #f_lbls #f_regs #restr whd in match push; normalize nodelta #st #bv @mfr_bind1
     381[ @(sigma_is prog f_lbls)
    1253382| whd in match is_push; normalize nodelta whd in match sigma_state; normalize nodelta
    1254383 cases (istack ? st) [2,3: #bv [2: #bv']]  whd in match sigma_is in ⊢ (???????%?);
     
    1259388
    1260389lemma be_opaccs_ok :
    1261 ∀prog : ertl_program. ∀sigma : sigma_map prog.
    1262 ∀ op.
     390∀prog : ertl_program. ∀f_lbls : lbl_funct. ∀ op.
    1263391preserving21 ?? res_preserve1 ??????
    1264     (sigma_beval prog sigma)
    1265     (sigma_beval prog sigma)
     392    (sigma_beval prog f_lbls)
     393    (sigma_beval prog f_lbls)
    1266394    (λx.let 〈bv1,bv2〉 ≝ x in
    1267            〈sigma_beval prog sigma bv1,
    1268             sigma_beval prog sigma bv2〉)
     395           〈sigma_beval prog f_lbls bv1,
     396            sigma_beval prog f_lbls bv2〉)
    1269397    (be_opaccs op)
    1270398    (be_opaccs op).
     
    1290418qed.
    1291419
    1292 lemma be_op1_ok : ∀prog : ertl_program. ∀sigma : sigma_map prog.
     420lemma be_op1_ok : ∀prog : ertl_program.  ∀f_lbls : lbl_funct.
    1293421∀ op.
    1294422preserving1 ?? res_preserve1 …
    1295      (sigma_beval prog sigma)
    1296      (sigma_beval prog sigma)
     423     (sigma_beval prog f_lbls)
     424     (sigma_beval prog f_lbls)
    1297425     (be_op1 op)
    1298426     (be_op1 op).
     
    1309437qed.
    1310438
    1311 lemma res_preserve_error11 : ∀X,Y,F,e,n. (∃e'.n = Error … e') →
    1312 res_preserve1 X Y F n (Error … e).
    1313 #X #Y #F #e #n * #e' #n_spec >n_spec @res_preserve_error1
    1314 qed.
    1315 
    1316 
    1317 lemma be_op2_ok : ∀prog : ertl_program. ∀sigma : sigma_map prog.
     439
     440lemma be_op2_ok : ∀prog : ertl_program. ∀f_lbls : lbl_funct.
    1318441∀ b,op.
    1319442preserving21 ?? res_preserve1 …
    1320      (sigma_beval prog sigma)
    1321      (sigma_beval prog sigma)
    1322      (λx.let 〈bv,b〉≝ x in 〈sigma_beval prog sigma bv,b〉)
     443     (sigma_beval prog f_lbls)
     444     (sigma_beval prog f_lbls)
     445     (λx.let 〈bv,b〉≝ x in 〈sigma_beval prog f_lbls bv,b〉)
    1323446     (be_op2 b op)
    1324447     (be_op2 b op).
     
    1365488                                 ] normalize nodelta try @res_preserve_error1
    1366489                                 @mfr_return_eq1 %
    1367        |3,6,9,12,15,18: #bi cases(op2 ?????) #by #bi1 normalize nodelta
     490       |3,6,9,12,15,18: #bi try(@mfr_return_eq1 %) cases(op2 ?????) #by #bi1 normalize nodelta
    1368491                        @mfr_return_eq1 %
    1369492       ]
     
    1412535qed.
    1413536
    1414 lemma pointer_of_address_ok : ∀prog : ertl_program. ∀sigma : sigma_map prog.
     537lemma pointer_of_address_ok : ∀prog : ertl_program.∀f_lbls : lbl_funct.
    1415538preserving1 … res_preserve1 …
    1416      (λx.let 〈bv1,bv2〉 ≝ x in〈sigma_beval prog sigma bv1,
    1417            sigma_beval prog sigma bv2〉)
     539     (λx.let 〈bv1,bv2〉 ≝ x in〈sigma_beval prog f_lbls bv1,
     540           sigma_beval prog f_lbls bv2〉)
    1418541     (λx.x)
    1419542     pointer_of_address pointer_of_address.
     
    1432555qed.
    1433556
    1434 lemma beloadv_ok : ∀prog : ertl_program. ∀sigma : sigma_map prog.
     557lemma beloadv_ok : ∀prog : ertl_program. ∀f_lbls : lbl_funct.
    1435558∀ptr.
    1436559preserving1 … opt_preserve1 …
    1437      (sigma_mem prog sigma)
    1438      (sigma_beval prog sigma)
     560     (sigma_mem prog f_lbls)
     561     (sigma_beval prog f_lbls)
    1439562     (λm.beloadv m ptr)
    1440563     (λm.beloadv m ptr).
     
    1450573qed.
    1451574
    1452 lemma bestorev_ok : ∀prog : ertl_program.∀sigma : sigma_map prog.
     575lemma bestorev_ok : ∀prog : ertl_program.∀f_lbls : lbl_funct.
    1453576∀ptr.
    1454577preserving21 … opt_preserve1 …
    1455     (sigma_mem prog sigma)
    1456     (sigma_beval prog sigma)
    1457     (sigma_mem prog sigma)
     578    (sigma_mem prog f_lbls)
     579    (sigma_beval prog f_lbls)
     580    (sigma_mem prog f_lbls)
    1458581    (λm.bestorev m ptr)
    1459582    (λm.bestorev m ptr).
     
    1534657qed.
    1535658
    1536 lemma match_reg_elim : ∀ A : Type[0]. ∀ P : A → Prop. ∀ r : region.
    1537 ∀f : (r = XData) → A. ∀g : (r = Code) → A. (∀ prf : r = XData.P (f prf)) →
    1538 (∀ prf : r = Code.P (g prf)) →
    1539 P ((match r return λx.(r = x → ?) with
    1540     [XData ⇒ f | Code ⇒ g])(refl ? r)).
    1541 #A #P * #f #g #H1 #H2 normalize nodelta [ @H1 | @H2]
    1542 qed.
    1543 
    1544659
    1545660lemma sp_ok : ∀prog : ertl_program.
    1546 good : (∀fn.good_state_transformation prog fn).
    1547 restr.
     661f_lbls : lbl_funct.
     662f_regs : regs_funct.∀restr.
    1548663   preserving1 … res_preserve1 …
    1549       (λst.sigma_state prog good st restr)
     664      (λst.sigma_state prog f_lbls f_regs restr st)
    1550665      (λx.x)
    1551666      (sp ERTL_semantics)
    1552667      (sp ERTLptr_semantics).
    1553 #prog #good #restr #st whd in match sp; normalize nodelta
     668#prog #f_lbls #f_regs #restr #st whd in match sp; normalize nodelta
    1554669whd in match (load_sp ??); whd in match (load_sp ??); whd in match sigma_state;
    1555670normalize nodelta whd in match sigma_regs; normalize nodelta
     
    1558673#pt #EQ lapply(jmeq_to_eq ??? EQ) -EQ whd in match hwreg_retrieve; normalize nodelta
    1559674whd in match sigma_hw_register_env; normalize nodelta
    1560 change with (sigma_beval ? (get_sigma_from_good_state … good) BVundef) in ⊢ (??(?(???(?????%)(?????%)))? → ?);
     675change with (sigma_beval prog f_lbls BVundef) in ⊢ (??(?(???(?????%)(?????%)))? → ?);
    1561676>lookup_map >lookup_map
    1562677cases(lookup beval 6 (bitvector_of_register RegisterSPL) (reg_env hw_r) BVundef)
     
    1579694
    1580695lemma set_sp_ok :  ∀prog : ertl_program.
    1581 good : (∀fn.good_state_transformation prog fn).
    1582 restr.∀ptr,st.
    1583 set_sp ? ptr (sigma_state prog good st restr) =
    1584 sigma_state prog good (set_sp ? ptr st) restr.
    1585 #prog #good #restr #ptr #st whd in match set_sp; whd in match sigma_state;
     696f_lbls : lbl_funct.
     697f_regs : regs_funct.∀restr.∀ptr,st.
     698set_sp ? ptr (sigma_state prog f_lbls f_regs restr st) =
     699sigma_state prog f_lbls f_regs restr (set_sp ? ptr st).
     700#prog #f_lbls #f_regs #restr #ptr #st whd in match set_sp; whd in match sigma_state;
    1586701normalize nodelta @eq_f2 [2: %] whd in match (save_sp ???);
    1587702whd in match (save_sp ???); whd in match sigma_regs; normalize nodelta
     
    1592707qed.
    1593708
     709(*TO BE MOVED IN TranslateUtils.ma *)
     710include "utilities/listb_extra.ma".
     711lemma not_in_added_registers : ∀p : graph_params.
     712∀globals : list ident.∀fn,f_regs,r.
     713(∀lbl. code_has_label p globals (joint_if_code … fn) lbl →
     714       opt_All … (λl.¬(bool_to_Prop (r ∈ l))) (f_regs lbl)) →
     715¬ (r ∈ (set_from_list RegisterTag (added_registers p globals fn f_regs))).
     716#p #globals #fn #f_regs #r #H whd in match added_registers; normalize nodelta
     717@foldi_ind [@I] #lbl #labels_fn #stmt #regs * #lbl_not_in_fn #EQstmt #IH
     718lapply(Prop_notb … IH) -IH * #IH
     719lapply(H lbl ?)
     720 [whd in match code_has_label; whd in match code_has_point; normalize nodelta
     721  whd in match (stmt_at ????); >EQstmt @I] cases(f_regs lbl)
     722  [ #_ @notb_Prop % assumption]
     723#l whd in ⊢ (% → ?); normalize nodelta * #H1 @notb_elim @if_elim [2: #_ @I] #ABS
     724lapply(mem_list_as_set … ABS) #ABS' cases(Exists_append … ABS') #ABS''
     725[ @H1 @Exists_memb lapply ABS'' elim l [ *] #hd #tl #IH whd in ⊢ (% → %);
     726  * [ #EQ >EQ % %] #H %2 @IH @H
     727| @IH @list_as_set_mem assumption
     728]
     729qed.
     730
     731include alias "basics/lists/listb.ma".
     732
     733(*RIFARE!!!*)
    1594734lemma eval_seq_no_pc_no_call_ok :
    1595735∀prog : ertl_program.
    1596 let trans_prog ≝ (ertl_to_ertlptr prog) in
    1597 ∀good : (∀fn.good_state_transformation prog fn).
    1598 ∀stack_size. ∀id. ∀fn : (joint_closed_internal_function ??) .∀seq.
     736let trans_prog ≝ ertl_to_ertlptr prog in
     737∀f_lbls : lbl_funct. ∀f_regs : regs_funct.
     738∀stack_size.
     739∀bl.∀id. ∀fn : (joint_closed_internal_function ? (prog_var_names ?? prog)).
     740∀fn_out : (joint_closed_internal_function ? (prog_var_names ?? trans_prog)).
     741∀seq.
     742(∀l. code_has_label … (joint_if_code … fn) l → 
     743opt_All …
     744       (λlabs.(All … (λreg.bool_to_Prop(¬(reg ∈ labs)))
     745              (get_used_registers_from_seq … (functs … ERTL) seq)))
     746       (f_regs bl l))  →
    1599747   preserving1 ?? res_preserve1 ????
    1600       (λst.sigma_state prog good st (added_registers … fn (f_regs … (good fn))))
    1601       (λst.sigma_state prog good st (added_registers … fn (f_regs … (good fn))))
     748      (sigma_state prog f_lbls f_regs (added_registers … fn (f_regs bl)))
     749      (sigma_state prog f_lbls f_regs (added_registers … fn (f_regs bl)))
    1602750      (eval_seq_no_pc ERTL_semantics
    1603751             (globals (mk_prog_params ERTL_semantics prog stack_size))
    1604752             (ev_genv (mk_prog_params ERTL_semantics prog stack_size)) id fn seq)
    1605753      (eval_seq_no_pc ERTLptr_semantics
    1606   (globals (mk_prog_params ERTLptr_semantics trans_prog stack_size))
    1607   (ev_genv (mk_prog_params ERTLptr_semantics trans_prog stack_size)) id (translate_internal … fn) (seq_embed … seq)).
    1608 #prog #good #stack_size #f #fn *
    1609 whd in match eval_seq_no_pc; normalize nodelta
    1610 [ #c #st @mfr_return1
    1611 | #c #st @mfr_return1
    1612 | #pm #st whd in match pair_reg_move; normalize nodelta
     754             (globals (mk_prog_params ERTLptr_semantics trans_prog stack_size))
     755             (ev_genv (mk_prog_params ERTLptr_semantics trans_prog stack_size))
     756             id fn_out (seq_embed … seq)).
     757#prog #f_lbls #f_regs #stack_size #bl #f #fn #fn_out #seq #fresh_regs
     758cases seq in fresh_regs;
     759[ #c #_ #st @mfr_return1
     760| #pm #fesh_regs #st whd in match pair_reg_move; normalize nodelta
    1613761  @mfr_bind1
    1614   [ 2: change with (ertl_eval_move ??) in ⊢ (???????%%); @ertl_eval_move_ok
     762  [ 2: change with (ertl_eval_move ??) in ⊢ (???????%%); @ertl_eval_move_ok
     763       whd in match move_dst_not_fresh; normalize nodelta cases pm in fesh_regs;
     764       * [#r1 | #R1] #m_src [2: #_ @I] normalize nodelta #fresh_regs
     765       @not_in_added_registers #lbl #Hlbl lapply(fresh_regs lbl Hlbl)
     766       cases(f_regs bl lbl) [ #_ @I] #labs whd in ⊢ (% → %); * #H #_ @Prop_notb @H
    1615767  | | #regs  @mfr_return_eq1 %
    1616768  ]
    1617 | #r #st @mfr_bind1
     769| #r #fresh_regs #st @mfr_bind1
    1618770  [2:  @pop_ok |
    1619771  | * #bv #st whd in match acca_store; normalize nodelta @mfr_bind1
    1620     [2: @ps_reg_store_ok |
     772    [2: @ps_reg_store_ok @not_in_added_registers #lbl #Hlbl
     773       lapply(fresh_regs lbl Hlbl)
     774       cases(f_regs bl lbl) [ #_ @I] #labs whd in ⊢ (% → %); * #H #_ @Prop_notb @H |
    1621775    | #regs  @mfr_return_eq1 %
    1622776    ]
    1623777  ]
    1624 | #r #st @mfr_bind1
     778| #r #_ #st @mfr_bind1
    1625779  [2: whd in match acca_arg_retrieve; normalize nodelta @ps_arg_retrieve_ok |
    1626780  | #bv @push_ok
     
    1631785  #dpl
    1632786  change with ((dph_reg ERTL) → ?)
    1633   #dph #st @mfr_bind1
    1634   [ @(λst.sigma_state prog good st (added_registers … fn (f_regs … (good fn))))
     787  #dph #fresh_regs #st @mfr_bind1
     788  [ @(sigma_state prog f_lbls f_regs (added_registers … fn (f_regs bl)))
    1635789  | whd in match dpl_store; normalize nodelta @mfr_bind1
    1636790    [2: @opt_safe_elim #bl #EQbl
    1637791       @opt_safe_elim #bl'
    1638792       >(find_symbol_transf …
    1639           (λvars.transf_fundef … (λfn.(translate_internal … fn))) prog i) in ⊢ (%→?);
     793          (λvars.transf_fundef … (λfn.(b_graph_translate … fn))) prog i) in ⊢ (%→?);
    1640794       >EQbl #EQ destruct whd in match sigma_state; normalize nodelta       
    1641        change with (sigma_beval prog (get_sigma_from_good_state … good) (BVptr …))
     795       change with (sigma_beval prog f_lbls (BVptr …))
    1642796                                               in ⊢ (???????(?????%?)?);
    1643        @ps_reg_store_ok |
     797       @ps_reg_store_ok @not_in_added_registers #lbl #Hlbl lapply(fresh_regs lbl Hlbl)
     798       cases(f_regs bl lbl) [ #_ @I] #labs whd in ⊢ (% → %); * #H #_ @Prop_notb @H |
    1644799    | #regs  @mfr_return_eq1 %
    1645800    ]
    1646801  | #st1 @opt_safe_elim #bl #EQbl @opt_safe_elim #bl'   
    1647     >(find_symbol_transf …
    1648           (λvars.transf_fundef … (λfn.(translate_internal … fn))) prog i) in ⊢ (%→?);
     802   >(find_symbol_transf …
     803          (λvars.transf_fundef … (λfn.(b_graph_translate … fn))) prog i) in ⊢ (%→?);
    1649804    >EQbl #EQ destruct whd in match dph_store; normalize nodelta @mfr_bind1
    1650805    [2: whd in match sigma_state; normalize nodelta       
    1651        change with (sigma_beval prog (get_sigma_from_good_state … good) (BVptr …))
     806       change with (sigma_beval prog f_lbls (BVptr …))
    1652807                                               in ⊢ (???????(?????%?)?);
    1653       @ps_reg_store_ok |
     808      @ps_reg_store_ok @not_in_added_registers #lbl #Hlbl lapply(fresh_regs lbl Hlbl)
     809       cases(f_regs bl lbl) [ #_ @I] #labs whd in ⊢ (% → %); * #_ whd in ⊢ (% → ?); * #H
     810       #_ @Prop_notb @H|
    1654811    | #regs  @mfr_return_eq1 %
    1655812    ]
    1656   ]
    1657 | #op #a #b #arg1 #arg2 #st @mfr_bind1
     813  ]    
     814| #op #a #b #arg1 #arg2 #fresh_regs #st @mfr_bind1
    1658815  [2: whd in match acca_arg_retrieve; whd in match sigma_state; normalize nodelta
    1659816     @ps_arg_retrieve_ok |
     
    1664821     [2: @be_opaccs_ok |
    1665822     | * #bv3 #bv4 normalize nodelta @mfr_bind1
    1666        [ @(λst.sigma_state prog good st (added_registers … fn (f_regs … (good fn))))
     823       [ @(sigma_state prog f_lbls f_regs (added_registers … fn (f_regs bl)))
    1667824       | whd in match acca_store; normalize nodelta @mfr_bind1
    1668          [2: @ps_reg_store_ok |
     825         [2: @ps_reg_store_ok @not_in_added_registers #lbl #Hlbl
     826             lapply(fresh_regs lbl Hlbl)
     827             cases(f_regs bl lbl) [ #_ @I] #labs whd in ⊢ (% → %); * #H #_ @Prop_notb @H |
    1669828         | #regs  @mfr_return_eq1 %
    1670829         ]
    1671830       | #st1 whd in match accb_store; normalize nodelta @mfr_bind1
    1672831         [2: whd in match sigma_state; normalize nodelta
    1673             @ps_reg_store_ok |
     832            @ps_reg_store_ok @not_in_added_registers #lbl #Hlbl
     833            lapply(fresh_regs lbl Hlbl)
     834            cases(f_regs bl lbl) [ #_ @I] #labs whd in ⊢ (% → %); * #_ * #H #_
     835            @Prop_notb @H |
    1674836         | #regs  @mfr_return_eq1 %
    1675837         ]         
     
    1678840   ]
    1679841  ] 
    1680 | #op #r1 #r2 #st @mfr_bind1
    1681   [ @(sigma_beval prog (get_sigma_from_good_state … good))
     842| #op #r1 #r2 #fresh_regs #st @mfr_bind1
     843  [ @(sigma_beval prog f_lbls)
    1682844  | whd in match acca_retrieve; normalize nodelta @ps_reg_retrieve_ok
    1683845  | #bv1 @mfr_bind1
    1684     [ @(sigma_beval prog (get_sigma_from_good_state … good))
     846    [ @(sigma_beval prog f_lbls)
    1685847    | @be_op1_ok
    1686848    | #bv2 whd in match acca_store; normalize nodelta @mfr_bind1
    1687       [2: whd in match sigma_state; normalize nodelta @ps_reg_store_ok |
     849      [2: whd in match sigma_state; normalize nodelta @ps_reg_store_ok
     850          @not_in_added_registers #lbl #Hlbl lapply(fresh_regs lbl Hlbl)
     851       cases(f_regs bl lbl) [ #_ @I] #labs whd in ⊢ (% → %); * #H #_ @Prop_notb @H |
    1688852      | #regs  @mfr_return_eq1 %
    1689853      ]
    1690854    ]
    1691855  ]
    1692 | #op2 #r1 #r2 #arg #st @mfr_bind1
     856| #op2 #r1 #r2 #arg #fresh_regs #st @mfr_bind1
    1693857  [2: whd in match acca_arg_retrieve; normalize nodelta @ps_arg_retrieve_ok |
    1694858  | #bv @mfr_bind1
     
    1697861      [2: @be_op2_ok |
    1698862      | * #bv2 #b @mfr_bind1
    1699         [ @(λst.sigma_state prog good st (added_registers … fn (f_regs … (good fn))))
     863        [ @(sigma_state prog f_lbls f_regs (added_registers … fn (f_regs bl)))
    1700864        | whd in match acca_store; normalize nodelta @mfr_bind1
    1701           [2: whd in match sigma_state; normalize nodelta @ps_reg_store_ok |
     865          [2: whd in match sigma_state; normalize nodelta @ps_reg_store_ok
     866              @not_in_added_registers #lbl #Hlbl lapply(fresh_regs lbl Hlbl)
     867              cases(f_regs bl lbl) [ #_ @I] #labs whd in ⊢ (% → %); * #H #_ @Prop_notb @H |
    1702868          | #regs  @mfr_return_eq1 %
    1703869          ]
     
    1707873    ]
    1708874  ]
    1709 | #st @mfr_return_eq1 %
    1710 | #st @mfr_return_eq1 %
    1711 | #r1 #dpl #dph #st @mfr_bind1
     875| #_ #st @mfr_return_eq1 %
     876| #_ #st @mfr_return_eq1 %
     877| #r1 #dpl #dph #fresh_regs #st @mfr_bind1
    1712878  [2: whd in match dph_arg_retrieve; normalize nodelta @ps_arg_retrieve_ok |
    1713879  | #bv @mfr_bind1
     
    1719885        [2: @opt_to_res_preserve1 @beloadv_ok |
    1720886        | #bv2 whd in match acca_store; normalize nodelta @mfr_bind1
    1721           [2: whd in match sigma_state; normalize nodelta @ps_reg_store_ok |
     887          [2: whd in match sigma_state; normalize nodelta @ps_reg_store_ok
     888              @not_in_added_registers #lbl #Hlbl lapply(fresh_regs lbl Hlbl)
     889              cases(f_regs bl lbl) [ #_ @I] #labs whd in ⊢ (% → %); * #H #_ @Prop_notb @H |
    1722890          | #regs  @mfr_return_eq1 %
    1723891          ]
     
    1726894    ]
    1727895  ] 
    1728 | #dpl #dph #r #st @mfr_bind1
     896| #dpl #dph #r #_ #st @mfr_bind1
    1729897  [2: whd in match dph_arg_retrieve; normalize nodelta @ps_arg_retrieve_ok |
    1730898  | #bv @mfr_bind1
     
    1743911    ]
    1744912  ]
    1745 | #ext #st whd in ⊢ (???????%%); whd in match (stack_sizes ????); cases (stack_size f)
     913| #ext #fresh_regs #st whd in ⊢ (???????%%); whd in match (stack_sizes ????); cases (stack_size f)
    1746914  normalize nodelta
    1747915  [ @res_preserve_error1
    1748   | #n cases ext normalize nodelta
    1749     [1,2: @mfr_bind1
     916  | #n cases ext in fresh_regs; normalize nodelta
     917    [1,2: #_ @mfr_bind1
    1750918      [1,4: @(λx.x)
    1751919      |2,5: @sp_ok
    1752920      |3,6: #ptr @mfr_return_eq1 >set_sp_ok %
    1753921      ]
    1754     | #r whd in match ps_reg_store_status; normalize nodelta @mfr_bind1
     922    | #r #fresh_regs whd in match ps_reg_store_status; normalize nodelta @mfr_bind1
    1755923      [2: whd in match sigma_state; normalize nodelta
    1756           change with (sigma_beval ? (get_sigma_from_good_state … good) (BVByte ?))
     924          change with (sigma_beval prog f_lbls (BVByte ?))
    1757925               in ⊢ (???????(??%?)?);
    1758           @ps_reg_store_ok
     926          @ps_reg_store_ok @not_in_added_registers #lbl #Hlbl lapply(fresh_regs lbl Hlbl)
     927          cases(f_regs bl lbl) [ #_ @I] #labs whd in ⊢ (% → %); * #H #_ @Prop_notb @H
    1759928      |
    1760929      | #regs @mfr_return_eq1 %
     
    1766935
    1767936lemma partial_inj_sigma : ∀ prog : ertl_program.
    1768 ∀good : (∀fn.good_state_transformation prog fn).
    1769 let sigma ≝ (get_sigma_from_good_state … good) in
    1770 ∀fn,lbl1,lbl2. sigma fn lbl1 ≠ None ? → sigma fn lbl1 = sigma fn lbl2 → lbl1 = lbl2.
    1771 #prog #good #fn #lbl1 #lbl2 inversion(get_sigma_from_good_state … lbl1)
    1772 [#_ * #H @⊥ @H %] #lbl1' whd in match get_sigma_from_good_state; normalize nodelta
    1773 #H @('bind_inversion H) -H * #lbl1'' #stmt1 #H1 whd in ⊢ (??%? → ?); #EQ destruct
    1774 #_ #H lapply(sym_eq ??? H) -H #H @('bind_inversion H) -H * #lbl2' #stmt2 #H2
     937∀f_lbls : lbl_funct.
     938let sigma ≝ get_sigma prog f_lbls in
     939∀id,lbl1,lbl2. sigma id lbl1 ≠ None ? → sigma id lbl1 = sigma id lbl2 → lbl1 = lbl2.
     940#prog #good #bl #lbl1 #lbl2 inversion(get_sigma … lbl1)
     941[#_ * #H @⊥ @H %] #lbl1' whd in match get_sigma; normalize nodelta
     942#H @('bind_inversion H) -H #bl' whd in match code_block_of_block; normalize nodelta
     943@match_reg_elim [#_ #ABS destruct] #prf #EQ destruct #H @('bind_inversion H) -H
     944* #id #fn #H lapply(res_eq_from_opt ??? H) -H #EQfn #H @('bind_inversion H) -H
     945* #lbl1'' #stmt1 #H1 whd in ⊢ (??%? → ?); #EQ destruct
     946#_ #H lapply(sym_eq ??? H) -H >m_return_bind >EQfn >m_return_bind
     947#H @('bind_inversion H) -H * #lbl2' #stmt2 #H2
    1775948whd in ⊢ (??%? → ?); #EQ destruct lapply(find_predicate ?????? H1)
    1776 lapply(find_predicate ?????? H2) cases(f_lbls ????) normalize nodelta [*]
    1777 * normalize nodelta
    1778 [@eq_identifier_elim #EQ1 * @eq_identifier_elim #EQ2 * >EQ1 >EQ2 % ]
    1779 #lb #tl @eq_identifier_elim #EQ1 * @eq_identifier_elim #EQ2 * >EQ1 >EQ2 %
    1780 qed.
     949lapply(find_predicate ?????? H2) cases(good ??) normalize nodelta [*]
     950*
     951  [ normalize nodelta @eq_identifier_elim #EQ1 *
     952    @eq_identifier_elim #EQ2 * >EQ1 >EQ2 %
     953  | #lb #tl whd in match split_on_last; normalize nodelta whd in match (foldr ?????);
     954    cases( foldr label (option (list label×label)) … tl) normalize nodelta
     955    [2: * #x #lb1] @eq_identifier_elim #EQ1 * @eq_identifier_elim #EQ2 *
     956    >EQ1 >EQ2 %
     957  ]
     958qed.
    1781959
    1782960lemma pc_of_label_eq :
    1783   ∀p,p'.let pars ≝ make_sem_graph_params p p' in
     961  ∀p,p'.let pars ≝ mk_sem_graph_params p p' in
    1784962  ∀globals,ge,bl,i_fn,lbl.
    1785963  fetch_internal_function ? ge bl = return i_fn →
     
    1793971lemma pop_ra_ok :
    1794972∀prog : ertl_program.
    1795 good : (∀fn.good_state_transformation prog fn).
     973f_lbls : lbl_funct. ∀f_regs : regs_funct.
    1796974∀restr.
    1797975preserving1 … res_preserve1 …
    1798      (λst.sigma_state prog good st restr)
     976     (sigma_state prog f_lbls f_regs restr)
    1799977     (λx.let 〈st,pc〉 ≝ x in
    1800          let sigma ≝ (get_sigma_from_good_state … good) in
    1801        〈sigma_state prog good st restr,
    1802         sigma_stored_pc ? sigma pc〉)
     978       〈sigma_state prog f_lbls f_regs restr st,
     979        sigma_stored_pc prog f_lbls pc〉)
    1803980     (pop_ra ERTL_semantics)
    1804      (pop_ra ERTLptr_semantics).
    1805 #prog #good #restr #st whd in match pop_ra; normalize nodelta @mfr_bind1
     981     (pop_ra ERTLptr_semantics).   
     982#prog #f_lbls #f_regs #restr1 #st whd in match pop_ra; normalize nodelta
     983@mfr_bind1
    1806984[ | @pop_ok ] * #bv #st1 @mfr_bind1 [ | @pop_ok] * #bv1 #st2 @mfr_bind1
    1807 [ @(sigma_stored_pc ? (get_sigma_from_good_state … good))
     985[ @(sigma_stored_pc prog f_lbls)
    1808986| whd in match pc_of_bevals; normalize nodelta
    1809987  cases bv [ | | #ptr1 #ptr2 #p | #by | #p | #ptr #p | #pc #p]
     
    18221000   whd in match sigma_pc_opt; normalize nodelta @if_elim
    18231001  [ #H2 #EQ lapply(sym_eq ??? EQ) -EQ @if_elim [#_  whd in ⊢ (??%% → ?); #EQ destruct %]
    1824     #H3 #H @('bind_inversion H) -H #x #_ #H @('bind_inversion H) -H #y #_
    1825     cases sigma_pc1 in H2; #bl_pc1 #z #H2 whd in ⊢ (??%? → ?); #EQ destruct >H2 in H3; *
     1002    #H3 #H @('bind_inversion H) -H #x #H4 whd in ⊢ (??%? → ?); #EQ destruct >H2 in H3; *
    18261003  | #H2 @if_elim
    1827     [ #H3 #H @('bind_inversion H) -H #x1 #_ #H @('bind_inversion H) -H #lbl1 #_
    1828       cases pc in H2; #bl #z #H2 whd in match pc_of_point; normalize nodelta whd in ⊢ (??%? → ?);
    1829       #EQ destruct >H3 in H2; *
     1004    [ #H3 #H @('bind_inversion H) -H #x1 #_ whd in match pc_of_point; normalize nodelta
     1005      whd in ⊢ (??%? → ?); #EQ destruct >H3 in H2; *
    18301006    | #H3 lapply sigma_pc1_spec; whd in match sigma_pc_opt; normalize nodelta @if_elim
    1831      [#H >H in H3; *] #_ #EQ >EQ @('bind_inversion EQ) -EQ #x #x_spec
    1832      lapply(res_eq_from_opt ??? x_spec) -x_spec #x_spec #H @('bind_inversion H) * #lbl
    1833      #lbl_spec whd in match pc_of_point; normalize nodelta cases sigma_pc1 #bl1 #lbl1
    1834      whd in match (offset_of_point ??); whd in ⊢ (??%? → ?); #EQ destruct cases pc #bl2 #p2
    1835      #H @('bind_inversion H) -H #x1 #x1_spec lapply(res_eq_from_opt ??? x1_spec) -x1_spec #x1_spec
    1836      #H @('bind_inversion H) -H * #lbl2 #lbl2_spec
     1007     [#H >H in H3; *] #_ #EQ >EQ @('bind_inversion EQ) -EQ * #x cases pc1 #bl1 #pos1
     1008     whd in match (point_of_pc ??); #x_spec whd in match (pc_of_point ???);
    18371009     whd in match (offset_of_point ??); whd in ⊢ (??%? → ?); #EQ destruct
    1838      <lbl_spec in lbl2_spec; #EQsig >x_spec in x1_spec; whd in ⊢ (??%% → ?); #EQ destruct
    1839      lapply(partial_inj_sigma … EQsig)
    1840      [>EQsig >lbl_spec % #ABS destruct] whd in match point_of_pc; normalize nodelta
    1841      whd in match (point_of_offset ??); whd in match (point_of_offset ??);
    1842      #EQ destruct cases pc1 #bl #p %
     1010     #H @('bind_inversion H) -H * #lbl cases pc #bl #pos whd in match (point_of_pc ??);
     1011     #lbl_spec whd in match pc_of_point; normalize nodelta
     1012     whd in match (offset_of_point ??); whd in ⊢ (??%? → ?); #EQ destruct
     1013     @eq_f cut(an_identifier LabelTag pos = an_identifier LabelTag pos1 → pos = pos1)
     1014     [ #EQ destruct %] #APP @APP @(partial_inj_sigma prog f_lbls bl1 …)
     1015     [ >lbl_spec % #EQ destruct] >x_spec >lbl_spec %
    18431016    ]
    18441017  ]
    18451018| #pc @mfr_return_eq1 %
    18461019]
     1020qed.
     1021
     1022lemma pc_block_eq : ∀prog : ertl_program. ∀f_lbls,pc.
     1023sigma_pc_opt prog f_lbls pc ≠ None ? →
     1024 pc_block … pc = pc_block … (sigma_stored_pc prog f_lbls pc).
     1025#prog #sigma * #bl #pos whd in match sigma_stored_pc; normalize nodelta
     1026inversion(sigma_pc_opt ???) [ #_ * #H @⊥ @H %] #pc
     1027whd in match sigma_pc_opt; normalize nodelta @if_elim
     1028[#_ whd in ⊢ (??%? → ?); #EQ destruct #_ %] #_
     1029#H @('bind_inversion H) -H * #lbl #_
     1030 whd in ⊢ (??%? → ?); #EQ destruct
     1031#_ %
     1032qed.
     1033
     1034include "joint/extra_joint_semantics.ma".
     1035
     1036lemma pop_frame_ok : ∀prog : ertl_program.
     1037let trans_prog ≝ ertl_to_ertlptr prog in
     1038∀f_lbls : lbl_funct. ∀f_regs : regs_funct.
     1039∀restr.
     1040preserving1 ?? res_preserve1 ????
     1041       (sigma_state prog f_lbls f_regs restr)
     1042       (λx.let 〈st,pc〉 ≝ x in
     1043           match fetch_internal_function ? (globalenv_noinit … prog)
     1044                 (pc_block pc) with
     1045                  [ OK y ⇒ let 〈id,f〉 ≝ y in
     1046                           〈sigma_state prog f_lbls f_regs
     1047                                 (added_registers ERTL (prog_var_names … prog) f
     1048                             (f_regs (pc_block pc))) st,
     1049                            sigma_stored_pc prog f_lbls pc〉
     1050                  | Error e ⇒ 〈dummy_state,null_pc one〉
     1051                  ])
     1052       (ertl_pop_frame)
     1053       (ertl_pop_frame).
     1054#prog #f_lbls #f_regs #restr #st whd in match ertl_pop_frame; normalize nodelta
     1055@mfr_bind1
     1056[ @(λx.match sigma_frames_opt prog f_lbls f_regs x with [Some l ⇒ l | None ⇒ [ ]])
     1057| @opt_to_res_preserve1 whd in match sigma_state; normalize nodelta
     1058  cases(st_frms … st) [@opt_preserve_none1] #l whd in match sigma_frames;
     1059  normalize  nodelta >m_return_bind #x #x_spec %{l} % [%] >x_spec %
     1060| * normalize nodelta [@res_preserve_error1] * #loc_mem #bl #tl normalize nodelta
     1061  inversion(sigma_frames_opt ????) normalize nodelta [ #_ @res_preserve_error1]
     1062  #l whd in match sigma_frames_opt; whd in match m_list_map; normalize nodelta
     1063  whd in match (foldr ?????); normalize nodelta inversion(fetch_internal_function ???)
     1064  normalize nodelta [2: #e #_ #ABS destruct(ABS)] * #f #fn #EQfn
     1065  #H @('bind_inversion H) -H #l1
     1066  change with (sigma_frames_opt prog f_lbls f_regs tl = ? → ?) #EQl1
     1067  whd in ⊢ (??%? → ?); #EQ destruct(EQ) @mfr_bind1
     1068  [2: whd in match sigma_state; whd in match set_regs; whd in match set_frms;
     1069     normalize nodelta
     1070     cut( 〈sigma_register_env prog f_lbls
     1071     (added_registers ERTL (prog_var_names (joint_function ERTL) ℕ prog) fn
     1072      (f_regs bl))
     1073     loc_mem,
     1074    \snd  (sigma_regs prog f_lbls restr (regs ERTLptr_semantics st))〉 =
     1075    sigma_regs prog f_lbls 
     1076     (added_registers ERTL (prog_var_names (joint_function ERTL) ℕ prog) fn
     1077      (f_regs bl)) (〈loc_mem,\snd  (regs ERTL_state st)〉)) [
     1078      whd in match sigma_regs; normalize nodelta cases(regs … st) #x1 #x2
     1079      %] #EQ >EQ -EQ <EQl1 in ⊢ (???????%?);
     1080      change with (sigma_state prog f_lbls f_regs
     1081    (added_registers ERTL (prog_var_names … prog) fn (f_regs bl))
     1082      (mk_state ? (Some ? tl) (istack … st) (carry … st) (〈loc_mem,\snd (regs … st)〉)
     1083      (m … st))) in ⊢ (???????(??%)?); @pop_ra_ok |
     1084  | * #st1 #pc1 @if_elim normalize nodelta [2: #_ @res_preserve_error1]
     1085   normalize nodelta @eq_block_elim [2: #_ *] #EQbl1 * @if_elim
     1086   [2: >EQbl1 @eq_block_elim [#_ *] * #H @⊥ @H <pc_block_eq [%] %
     1087       cases bl in EQbl1 EQfn; #p1 #p2 #EQ destruct lapply p2
     1088       whd in match sigma_stored_pc; normalize nodelta cases(sigma_pc_opt ???)
     1089       normalize nodelta [2: #pc2] #p2 [#_ #EQ destruct]
     1090       >fetch_internal_function_no_zero [2: %] #EQ destruct
     1091   |   @eq_block_elim [2: #_ *] #EQbl11 * @mfr_return_eq1 normalize nodelta
     1092       cases bl in EQbl11 EQfn; #p1 #p2 #EQ destruct
     1093       lapply p2 cases(pc_block pc1) #p11 #p22 #e #EQfn1 >EQfn1 %
     1094   ]
     1095  ]
     1096]
     1097qed.
     1098 
     1099(*
     1100  whd in match sigma_frames_opt; whd in match m_list_map; normalize nodelta
     1101whd in match sigma_state in ⊢ (???????%%); normalize nodelta
     1102cases(st_frms … st) normalize nodelta [ @res_preserve_error1]
     1103* #loc_mem #bl #tl inversion(sigma_frames ????)
     1104[ #_ normalize nodelta @res_preserve_error1] * #loc_mem1 #bl1 #tl1
     1105whd in match sigma_frames; normalize nodelta inversion(sigma_frames_opt ????)
     1106[ #_ normalize nodelta #_ #ABS destruct] #l whd in match sigma_frames_opt;
     1107whd in match m_list_map; normalize nodelta whd in match (foldr ?????);
     1108normalize nodelta inversion(fetch_internal_function ???)
     1109[2: #e #_ whd in ⊢ (??%% → ?); #ABS destruct] * #id1 #fn1 #EQfn1 >m_return_bind
     1110normalize nodelta #H @('bind_inversion H) -H #l1
     1111change with (sigma_frames_opt ???? = ? → ?) #EQl1
     1112cut (sigma_frames prog f_lbls f_regs tl = l1)
     1113[whd in match sigma_frames; normalize nodelta >EQl1 %] #EQl11
     1114cases l [ whd in ⊢ (??%? → ?); #EQ destruct] #x #y
     1115whd in ⊢ (??%? → ?); #EQ1 #_ #EQ2 destruct @mfr_bind1
     1116[2: whd in match set_regs; whd in match set_frms; normalize nodelta
     1117    >EQl1 in ⊢ (???????%?); normalize nodelta
     1118cut(sigma_regs prog f_lbls (added_registers ERTL (prog_var_names … prog) fn1 (f_regs bl1))
     1119    〈loc_mem,\snd (regs … st)〉 =  〈map RegisterTag beval beval loc_mem
     1120       (λbv:beval.sigma_beval prog f_lbls bv)∖
     1121         added_registers ERTL (prog_var_names … prog) fn1 (f_regs bl1),
     1122   \snd  (sigma_regs prog f_lbls restr (regs ERTLptr_semantics st))〉)
     1123[ whd in match sigma_regs; normalize nodelta @eq_f2 [ %] cases(regs ? st)
     1124     #x #y %] #EQ <EQ -EQ
     1125change with (sigma_state ???? (set_regs ERTL_semantics 〈loc_mem,\snd (regs … st)〉
     1126            (set_frms ERTL_semantics tl st))) in ⊢ (???????(??%)?);
     1127@pop_ra_ok |
     1128| * #st1 #pc1 @if_elim [2: #_ @res_preserve_error1] normalize nodelta
     1129@eq_block_elim [2: #_ *] #EQbl1 * @if_elim
     1130[2: >EQbl1 @eq_block_elim [#_ *] * #H @⊥ @H <pc_block_eq [%] %
     1131    cases bl1 in EQbl1 EQfn1; #p1 #p2 #EQ destruct lapply p2
     1132    whd in match sigma_stored_pc; normalize nodelta cases(sigma_pc_opt ???)
     1133    normalize nodelta [2: #pc2] #p2 [#_ #EQ destruct]
     1134    >fetch_internal_function_no_zero [2: %] #EQ destruct
     1135] @eq_block_elim [2: #_ *] #EQbl11 * @mfr_return_eq1 normalize nodelta
     1136  cases bl1 in EQbl11 EQfn1; #p1 #p2 #EQ destruct
     1137  lapply p2 cases(pc_block pc1) #p11 #p22 #e #EQfn1 >EQfn1
     1138  %
     1139]
     1140qed.
     1141*)
     1142
     1143
     1144definition ERTLptrStatusSimulation :
     1145∀ prog : ertl_program.
     1146let trans_prog ≝ ertl_to_ertlptr prog in
     1147∀stack_sizes.∀ f_lbls : lbl_funct. ∀ f_regs : regs_funct.
     1148∀f_bl_r.
     1149b_graph_transform_program_props ERTL_semantics ERTLptr_semantics
     1150     translate_data prog f_bl_r f_lbls f_regs →
     1151status_rel (ERTL_status prog stack_sizes) (ERTLptr_status trans_prog stack_sizes) ≝
     1152λprog,stack_sizes,f_lbls,f_regs,f_lb_r,good.
     1153  let trans_prog ≝ ertl_to_ertlptr prog in
     1154    mk_status_rel ??
     1155    (* sem_rel ≝ *) (λs1:ERTL_status prog stack_sizes
     1156       .λs2:ERTLptr_status trans_prog stack_sizes
     1157        .s1=sigma_state_pc prog f_lbls f_regs s2)
     1158    (* call_rel ≝ *) 
     1159          (λs1:Σs:ERTL_status prog stack_sizes
     1160               .as_classifier (ERTL_status prog stack_sizes) s cl_call
     1161       .λs2:Σs:ERTLptr_status trans_prog stack_sizes
     1162                .as_classifier (ERTLptr_status trans_prog stack_sizes) s cl_call
     1163        .
     1164        pc (mk_prog_params ERTL_semantics prog stack_sizes) s1
     1165         =sigma_stored_pc prog f_lbls
     1166          (pc
     1167           (mk_prog_params ERTLptr_semantics (ertl_to_ertlptr prog) stack_sizes)
     1168           s2))
     1169    (* sim_final ≝ *) ?.
     1170cases daemon
     1171qed.
     1172
     1173include "joint/semantics_blocks.ma".
     1174
     1175lemma fetch_ok_sigma_pc_ok :∀prog : ertl_program.
     1176∀ f_lbls,f_regs,id,fn,st.
     1177fetch_internal_function … (globalenv_noinit … prog)
     1178(pc_block (pc … (sigma_state_pc prog f_lbls f_regs st))) = return 〈id,fn〉 →
     1179pc … (sigma_state_pc prog f_lbls f_regs st) = pc … st.
     1180#prog #f_lbls #f_regs #id #fn #st whd in match sigma_state_pc;
     1181normalize nodelta cases(fetch_internal_function ?? (pc_block (pc … st)))
     1182normalize nodelta [* #id1 #fn1 #_ %]
     1183#e >fetch_internal_function_no_zero [2: %] whd in ⊢ (???% → ?); #EQ destruct(EQ)
     1184qed.
     1185
     1186lemma fetch_ok_sigma_state_ok : ∀prog : ertl_program.
     1187∀ f_lbls,f_regs,id,fn,st.
     1188fetch_internal_function … (globalenv_noinit … prog)
     1189(pc_block (pc … (sigma_state_pc prog f_lbls f_regs st))) = return 〈id,fn〉 →
     1190let added ≝ (added_registers ERTL (prog_var_names … prog) fn
     1191                                               (f_regs (pc_block (pc … st)))) in
     1192st_no_pc … (sigma_state_pc prog f_lbls f_regs st) =
     1193sigma_state prog f_lbls f_regs added (st_no_pc … st).
     1194#prog #f_lbls #f_regs #id #fn #st #EQf whd in match sigma_state_pc;
     1195normalize nodelta <(fetch_ok_sigma_pc_ok … EQf) >EQf %
     1196qed.
     1197
     1198lemma fetch_ok_sigma_pc_block_ok : ∀prog : ertl_program.
     1199∀ f_lbls,id,fn,pc.
     1200fetch_internal_function … (globalenv_noinit … prog)
     1201(pc_block (sigma_stored_pc prog f_lbls pc)) = return 〈id,fn〉 →
     1202pc_block (sigma_stored_pc prog f_lbls pc) = pc_block pc.
     1203#prog #f_lbls #id #fn #pc #EQf <pc_block_eq [%]
     1204lapply EQf whd in match sigma_stored_pc; normalize nodelta
     1205cases(sigma_pc_opt ???) normalize nodelta [2: #pc #_ % #EQ destruct(EQ)]
     1206>fetch_internal_function_no_zero [2: %] whd in ⊢ (???% → ?); #EQ destruct(EQ)
     1207qed.
     1208
     1209lemma fetch_stmt_ok_sigma_pc_ok : ∀prog : ertl_program.
     1210∀ f_lbls,f_regs,id,fn,stmt,st.
     1211fetch_statement ERTL_semantics (prog_var_names … prog)
     1212    (globalenv_noinit … prog) (pc … (sigma_state_pc prog f_lbls f_regs st)) =
     1213               return 〈id,fn,stmt〉 →
     1214pc … (sigma_state_pc prog f_lbls f_regs st) = pc … st.
     1215#prog #f_lbls #f_regs #id #fn #stmt #st #H @('bind_inversion H)
     1216* #id1 #fn1 #EQfn1 #_ @(fetch_ok_sigma_pc_ok … EQfn1)
     1217qed.
     1218
     1219lemma fetch_stmt_ok_sigma_state_ok : ∀prog : ertl_program.
     1220∀ f_lbls,f_regs,id,fn,stmt,st.
     1221fetch_statement ERTL_semantics (prog_var_names … prog)
     1222    (globalenv_noinit … prog) (pc … (sigma_state_pc prog f_lbls f_regs st)) =
     1223               return 〈id,fn,stmt〉 →
     1224let added ≝ (added_registers ERTL (prog_var_names … prog) fn
     1225                                               (f_regs (pc_block (pc … st)))) in
     1226st_no_pc … (sigma_state_pc prog f_lbls f_regs st) =
     1227sigma_state prog f_lbls f_regs added (st_no_pc … st).
     1228#prog #f_lbls #f_regs #id #fn #stmt #st #H @('bind_inversion H) -H
     1229* #id1 #fn1 #EQfn1 #H @('bind_inversion H) -H #stmt1 #_
     1230whd in ⊢ (??%% → ?); #EQ destruct(EQ) @(fetch_ok_sigma_state_ok … EQfn1)
     1231qed.
     1232
     1233lemma fetch_stmt_ok_sigma_pc_block_ok : ∀prog : ertl_program.
     1234∀ f_lbls,id,fn,stmt,pc.
     1235fetch_statement ERTL_semantics (prog_var_names … prog)
     1236  (globalenv_noinit … prog) (sigma_stored_pc prog f_lbls pc) = return 〈id,fn,stmt〉 →
     1237pc_block (sigma_stored_pc prog f_lbls pc) = pc_block pc.
     1238#prog #f_lbls #id #fn #stmt #st #H @('bind_inversion H) -H
     1239* #id1 #fn1 #EQfn1 #H @('bind_inversion H) -H #stmt1 #_
     1240whd in ⊢ (??%% → ?); #EQ destruct(EQ) @(fetch_ok_sigma_pc_block_ok … EQfn1)
     1241qed.
     1242
     1243lemma as_label_ok : ∀ prog : ertl_program.
     1244let trans_prog ≝ ertl_to_ertlptr prog in
     1245∀ f_lbls,f_regs,stack_sizes.
     1246∀f_bl_r.
     1247b_graph_transform_program_props ERTL_semantics ERTLptr_semantics
     1248     translate_data prog f_bl_r f_lbls f_regs →
     1249∀st,fn,id,stmt.
     1250fetch_statement ERTL_semantics (prog_var_names … prog)
     1251      (globalenv_noinit … prog) (pc … (sigma_state_pc prog f_lbls f_regs st)) =
     1252               return 〈id,fn,stmt〉 →
     1253as_label (ERTLptr_status trans_prog stack_sizes) st = as_label
     1254(ERTL_status prog stack_sizes) (sigma_state_pc prog f_lbls f_regs st).
     1255#prog #f_lbls #f_regs #stack_size #f_lb_r #good #st #fn #id #stmt #EQfetch
     1256whd in match as_label; normalize nodelta change with (pc ? ?) in ⊢ (??(??%)(??%));
     1257cases(b_graph_transform_program_fetch_statement … good … EQfetch)
     1258#init_data * #t_fn ** #EQt_fn whd in ⊢ (% → ?); cases(f_lb_r ?)
     1259normalize nodelta [2: #r #tl *] #EQinit destruct(EQinit) * #l_labs * #l_regs **
     1260#_ #_ cases stmt in EQfetch;
     1261[ * [ #c | * [ #c_id | #c_ptr ] #c_arg #c_dest | #reg #lbl | #s ] #nxt | #fin | * ]
     1262#EQfetch normalize nodelta * #bl * [1,2,3,4,5: >if_merge_right in ⊢ (% → ?); try %]
     1263whd in ⊢ (%→?); cases l_regs normalize nodelta [2,4,5,8,10,12: [3: *] #x #y *]
     1264[1,2,4,5,6:| #r #tl whd in ⊢ (% → ?); cases tl -tl normalize nodelta [2: #r1 #tl1 *]]
     1265#EQ destruct(EQ)
     1266[1,2,3,4,6: * #pre_l * #mid1 * #mid2 * #post_l *** #EQmid1
     1267            whd in match map_eval in ⊢ (% → ?); normalize nodelta
     1268            whd in ⊢ (?????%?? → ?);
     1269            whd in match (seq_list_in_code ???????) in ⊢ (%→?); *
     1270           [1,2,3,4: #EQ1 #EQ2 destruct(EQ1 EQ2) whd in EQmid1 : (???%);
     1271                     destruct(EQmid1) * #nxt1 * #EQt_stmt #_ #_
     1272           |        * #lbl1 * #rest ** #EQ destruct(EQ) * #nxt1 *
     1273                    #EQt_stmt #_ #_ #_ #_
     1274           ]
     1275|           * #pre_l * #mid ** #EQmid whd in ⊢ (% → ?); * #EQ destruct(EQ)
     1276            whd in EQmid : (???%); destruct(EQmid) #EQ destruct(EQ)
     1277            whd in ⊢ (% → ?); #EQt_stmt
     1278]
     1279whd in ⊢ (??%%); >EQfetch normalize nodelta whd in match fetch_statement;
     1280normalize nodelta >(fetch_stmt_ok_sigma_pc_ok … EQfetch) in EQt_fn;
     1281#EQt_fn >EQt_fn >m_return_bind >(fetch_stmt_ok_sigma_pc_ok … EQfetch) in EQt_stmt;
     1282#EQt_stmt >EQt_stmt %
     1283qed.
     1284
     1285lemma fetch_ok_sigma_last_pop_ok :∀prog : ertl_program.
     1286∀ f_lbls,f_regs,id,fn,st.
     1287fetch_internal_function … (globalenv_noinit … prog)
     1288(pc_block (pc … (sigma_state_pc prog f_lbls f_regs st))) = return 〈id,fn〉 →
     1289last_pop … (sigma_state_pc prog f_lbls f_regs st) =
     1290sigma_stored_pc prog f_lbls (last_pop … st).
     1291#prog #f_lbls #f_regs #id #fn #st whd in match sigma_state_pc; normalize nodelta
     1292cases(fetch_internal_function ?? (pc_block (pc … st))) normalize nodelta
     1293[ * #x #y #_ %] #e >fetch_internal_function_no_zero [2: %] whd in ⊢ (???% → ?);
     1294#EQ destruct(EQ)
     1295qed.
     1296
     1297lemma fetch_stmt_ok_sigma_last_pop_ok :∀prog : ertl_program.
     1298∀ f_lbls,f_regs,id,fn,stmt,st.
     1299fetch_statement ERTL_semantics (prog_var_names … prog)
     1300    (globalenv_noinit … prog) (pc … (sigma_state_pc prog f_lbls f_regs st))
     1301    = return 〈id,fn,stmt〉 →
     1302last_pop … (sigma_state_pc prog f_lbls f_regs st) =
     1303sigma_stored_pc prog f_lbls (last_pop … st).
     1304#prog #f_lbls #f_regs #id #fn #stmt #st #H @('bind_inversion H) -H
     1305* #id1 #fn1 #EQfn1 #H @('bind_inversion H) -H #stmt1 #_
     1306whd in ⊢ (??%% → ?); #EQ destruct(EQ) @(fetch_ok_sigma_last_pop_ok … EQfn1)
     1307qed.
     1308
     1309lemma excluded_middle_list :
     1310∀A : Type[0]. ∀P : A → Prop. (∀a.decidable … (P a)) → ∀ l.
     1311All … P l ∨ Exists … (λa.¬(P a)) l.
     1312#A #P #Dec #l elim l [% %] #hd #tl #IH
     1313cases IH [ cases(Dec hd) [ #H1 #H2 % whd % assumption | #H #_ %2 whd % assumption]
     1314         | #H %2 whd %2 assumption
     1315         ]
     1316qed.
     1317
     1318lemma eval_seq_no_call_ok :
     1319 ∀prog.
     1320 let trans_prog ≝ ertl_to_ertlptr prog in
     1321 ∀ f_lbls,f_regs,stack_sizes.
     1322 ∀f_bl_r.
     1323 b_graph_transform_program_props ERTL_semantics ERTLptr_semantics
     1324     translate_data prog f_bl_r f_lbls f_regs →
     1325 ∀st2 : state_pc ERTLptr_semantics.
     1326 let st1 ≝ sigma_state_pc prog f_lbls f_regs st2 in
     1327 ∀st1' : state_pc ERTL_semantics.
     1328 ∀f,fn,stmt,nxt.
     1329   fetch_statement ERTL_semantics
     1330     (prog_var_names (joint_function ERTL_semantics) ℕ prog)
     1331    (ev_genv (mk_prog_params ERTL_semantics prog stack_sizes))
     1332    (pc … st1) =
     1333      return 〈f, fn,  sequential … (step_seq ERTL … stmt) nxt〉 →
     1334   eval_state ERTL_semantics
     1335   (prog_var_names (joint_function ERTL_semantics) ℕ prog)
     1336   (ev_genv … (mk_prog_params ERTL_semantics prog stack_sizes))
     1337   st1 =
     1338    return st1' →
     1339 ∃st2'. st1' = sigma_state_pc prog f_lbls f_regs st2' ∧
     1340 ∃taf : trace_any_any_free (ERTLptr_status trans_prog stack_sizes)
     1341  st2
     1342  st2'.
     1343 if taaf_non_empty … taf then True else
     1344(¬as_costed (ERTL_status prog stack_sizes) st1 ∨
     1345 ¬as_costed (ERTL_status prog stack_sizes) st1').
     1346#prog #f_lbls #f_regs #stack_size #f_bl_r #good #st2 #st1' #f #fn #stmt #nxt
     1347#EQfetch whd in match eval_state; normalize nodelta >EQfetch >m_return_bind
     1348#H @('bind_inversion H)-H #st_no_pc
     1349whd in match eval_statement_no_pc; normalize nodelta #EQnopc
     1350whd in match eval_statement_advance; normalize nodelta
     1351whd in match set_no_pc; whd in match next; whd in match set_pc;
     1352normalize nodelta whd in ⊢ (??%% → ?); #EQ destruct(EQ) lapply EQfetch
     1353>(fetch_stmt_ok_sigma_pc_ok … EQfetch) #EQfetch'
     1354lapply(fetch_statement_inv … EQfetch') * #EQfn #EQstmt
     1355cases(b_graph_transform_program_fetch_internal_function … good … EQfn)
     1356#init_data * #t_fn1 ** #EQt_fn1 whd in ⊢ (% → ?); cases (f_bl_r ?) normalize nodelta
     1357[2: #r #tl *] #EQ destruct(EQ) * #_ #_ #_ #_ #_ #_ #_ #fresh_regs #_ #_ #stmt_at_spec
     1358cases(stmt_at_spec … EQstmt) #labs * #regs ** #EQlabs #EQregs normalize nodelta
     1359>if_merge_right in ⊢ (% → ?); [2: %] whd in ⊢ (% → ?); * #bl * whd in ⊢ (% → ?);
     1360cases regs in EQregs; -regs [2: #x #y #_ *] #EQregs normalize nodelta #EQ destruct(EQ)
     1361#eval_spec
     1362lapply(err_eq_from_io ????? EQnopc) -EQnopc >(fetch_stmt_ok_sigma_state_ok … EQfetch)
     1363#EQnopc
     1364cases(eval_seq_no_pc_no_call_ok prog f_lbls f_regs ????????? EQnopc)
     1365[2: @(t_fn1)
     1366| #stnopc'' * #EQstnopc'' #EQsem %
     1367  [ % [@stnopc'' | @(succ_pc ERTL_semantics (pc … st2) nxt) | @(last_pop … st2)]]
     1368  %
     1369  [ whd in match sigma_state_pc; normalize nodelta @('bind_inversion EQfetch)
     1370    * #f1 #fn1 >(fetch_stmt_ok_sigma_pc_ok … EQfetch) #EQfn1
     1371    #H @('bind_inversion H) -H #stmt1 #_ whd in ⊢ (??%% → ?); #EQ destruct(EQ)
     1372    >EQfn1 normalize nodelta >EQsem % ]
     1373  % [ @(produce_trace_any_any_free_coerced) [ @f | @t_fn1 |6: @eval_spec ||| @EQt_fn1]
     1374    whd in match repeat_eval_seq_no_pc; normalize nodelta whd in ⊢ (??%?);
     1375    >EQstnopc'' %] @if_elim [#_ @I] #_ %1 % whd in match as_costed;
     1376    normalize nodelta * #H @H whd in ⊢ (??%?); >EQfetch %
     1377| #lbl whd in match code_has_label; whd in match code_has_point; normalize nodelta
     1378  inversion(stmt_at ????) [#_ *] #stmt1 #EQstmt1 #_ cases(stmt_at_spec … EQstmt1)
     1379  #labels * #registers ** #_ #EQregisters #_ -labels >EQregisters whd
     1380  cases(excluded_middle_list ? (λreg.bool_to_Prop(¬(reg∈registers))) ?
     1381         (get_used_registers_from_seq … (functs ERTL) stmt))
     1382  [3: #a cases(¬a∈registers) // |1: #H assumption] #H @⊥
     1383  cases(Exists_All … H (regs_are_in_univers … (pi2 ?? fn) … EQstmt))
     1384  #reg ** #H1 #H2 @H1 -H1 @notb_Prop % #H1 lapply(fresh_regs … lbl) >EQregisters
     1385  whd in ⊢ (% → ?); #H3 lapply(All_memb … H3 H1) ** #H4 #_ @H4 assumption
     1386]
     1387qed.
     1388
     1389lemma eval_goto_ok :
     1390 ∀prog : ertl_program.
     1391 let trans_prog ≝ ertl_to_ertlptr prog in
     1392∀ f_lbls,f_regs,stack_sizes.
     1393 ∀f_bl_r.
     1394 b_graph_transform_program_props ERTL_semantics ERTLptr_semantics
     1395     translate_data prog f_bl_r f_lbls f_regs →
     1396 ∀st2.
     1397 let st1 ≝ (sigma_state_pc prog f_lbls f_regs st2) in
     1398 ∀st1',f,fn,nxt.
     1399   fetch_statement ERTL_semantics …
     1400    (globalenv_noinit ? prog) (pc … st1) =
     1401      return 〈f, fn,  final … (GOTO ERTL … nxt)〉 →
     1402   eval_state ERTL_semantics
     1403   (prog_var_names (joint_function ERTL_semantics) ℕ prog)
     1404   (ev_genv … (mk_prog_params ERTL_semantics prog stack_sizes))
     1405   st1 =
     1406    return st1' →
     1407    ∃ st2'. st1' = sigma_state_pc prog f_lbls f_regs st2' ∧
     1408 ∃taf : trace_any_any_free (ERTLptr_status trans_prog stack_sizes)
     1409  st2
     1410  st2'.
     1411  bool_to_Prop (taaf_non_empty … taf).
     1412#prog #f_lbls #f_regs #stack_size #f_bl_r #good #st2 #st1' #f #fn #nxt #EQfetch
     1413whd in match eval_state; normalize nodelta >EQfetch >m_return_bind
     1414whd in match eval_statement_no_pc; normalize nodelta
     1415>m_return_bind whd in match eval_statement_advance; whd in match set_no_pc;
     1416whd in match goto; normalize nodelta #H lapply(err_eq_from_io ????? H) -H
     1417#H @('bind_inversion H) -H #new_pc lapply(fetch_statement_inv … EQfetch) *
     1418#EQfn #_ >(pc_of_label_eq … EQfn) whd in ⊢ (??%% → ??%% → ?);
     1419#EQ1 #EQ2 destruct(EQ1 EQ2)
     1420% [ % [ @st2 | @(mk_program_counter (pc_block (pc … st2))
     1421                         (offset_of_point ERTL_semantics nxt)) | @(last_pop … st2)]]
     1422% [ >(fetch_stmt_ok_sigma_state_ok … EQfetch) >(fetch_stmt_ok_sigma_pc_ok … EQfetch)
     1423    >(fetch_stmt_ok_sigma_last_pop_ok … EQfetch) whd in match sigma_state_pc;
     1424    normalize nodelta >(fetch_stmt_ok_sigma_pc_ok … EQfetch) in EQfn; #EQfn
     1425    >EQfn %]
     1426cases(b_graph_transform_program_fetch_statement … good … EQfetch)
     1427#init_data * #t_fn1 ** #EQt_fn1 whd in ⊢ (% → ?); cases (f_bl_r ?) normalize nodelta
     1428[2: #r #tl *] #EQ destruct(EQ) * #labs **
     1429[2: #hd #tl ** #_ #_ ** #pre #inst * whd in ⊢ (%→?); *] ** #EQlabs #EQf_regs
     1430whd in match translate_fin_step; normalize nodelta * #bl *
     1431whd in ⊢ (% → ?); #EQ destruct(EQ) **
     1432[2: #lb #tl * #mid ** #EQmid whd in ⊢ (% → ?); * #ABS destruct(ABS)] * #mid **
     1433whd in ⊢ (???% → ?); #EQ destruct(EQ) * #_ #_ change with (stmt_at ???? = ? → ?)
     1434#EQstmt >(fetch_stmt_ok_sigma_pc_ok … EQfetch) in EQt_fn1; #EQt_fn1
     1435>(fetch_stmt_ok_sigma_pc_ok … EQfetch) in EQstmt; #EQstmt
     1436%{(taaf_step … (taa_base …) …)}
     1437[ whd in match as_classifier; normalize nodelta whd in ⊢ (??%?);
     1438  whd in match fetch_statement; normalize nodelta 
     1439  >EQt_fn1 >m_return_bind >EQstmt %
     1440| whd whd in match eval_state; normalize nodelta whd in match fetch_statement;
     1441  normalize nodelta  >EQt_fn1 >m_return_bind >EQstmt >m_return_bind
     1442  whd in match eval_statement_no_pc; normalize nodelta >m_return_bind
     1443  whd in match eval_statement_advance; normalize nodelta
     1444  whd in match goto; normalize nodelta >(pc_of_label_eq … EQt_fn1) %
     1445] @I
     1446qed.
     1447
     1448lemma code_block_of_block_eq : ∀bl : Σb.block_region b = Code.
     1449code_block_of_block bl = return bl.
     1450* #bl #prf whd in match code_block_of_block; normalize nodelta @match_reg_elim
     1451[ >prf in ⊢ (% → ?); #ABS destruct(ABS)] #prf1 %
     1452qed.
     1453
     1454(*
     1455lemma list_elim_on_last : ∀A : Type[0].∀ P : (list A) → Prop. ∀ l.
     1456                 P ([ ]) → (∀pre,last. P (pre@[last])) → P l.
     1457#A #P #l #H1 #H2 cut(∀A.∀l : list A.l = [ ] ∨ ∃pre,last. l = pre@[last])
     1458[ #A #l elim l [ %1 % | #a #tl * [ #EQ destruct %2 %{([ ])} %{a} %]
     1459* #l1 * #a1 #EQ destruct %2 %{(a::l1)} %{a1} %]] #APP1
     1460lapply(APP1 … l) * [ #EQ >EQ assumption]
     1461 * #pre * #last #EQ >EQ @H2
     1462qed.*)
     1463
     1464lemma split_on_last_append : ∀A : Type[0]. ∀pre : list A.
     1465∀ last : A. split_on_last ? (pre@[last]) = return 〈pre,last〉.
     1466#A #pre elim pre [#last %] #a #tl #IH #last whd in ⊢ (??%?);lapply(IH last)
     1467whd in ⊢ (??%? → ?); #EQ >EQ %
     1468qed.
     1469
     1470lemma append_All : ∀A : Type[0]. ∀ P : A → Prop. ∀l1,l2 : list A.
     1471All ? P (l1 @ l2) → All ? P l1 ∧ All ? P l2.
     1472#A #P #l1 elim l1
     1473[ #l2 change with l2 in ⊢ (???% → ?); #H % //]
     1474#a #tl #IH #l2 change with (P a ∧ All A P (tl @ l2)) in ⊢ (% → ?);
     1475* #H1 #H2 lapply(IH … H2) * #H3 #H4 % // whd % //
     1476qed.
     1477
     1478include alias "common/Identifiers.ma".
     1479
     1480lemma get_sigma_idempotent :
     1481∀prog : ertl_program.
     1482∀ f_lbls,f_regs.
     1483 ∀f_bl_r.
     1484 b_graph_transform_program_props ERTL_semantics ERTLptr_semantics
     1485     translate_data prog f_bl_r f_lbls f_regs →
     1486∀id,fn,bl,pt,stmt.
     1487fetch_internal_function … (globalenv_noinit … prog) bl = return 〈id,fn〉 →
     1488stmt_at ERTL (prog_var_names … prog) (joint_if_code … fn) pt = return stmt → 
     1489f_lbls bl pt = return [ ] → get_sigma prog f_lbls bl pt = return pt.
     1490#prog #f_lbls #f_regs #f_bl_r #good #id #fn #bl #pt #stmt #EQfn #EQstmt #EQlabels
     1491cases(b_graph_transform_program_fetch_internal_function … good … EQfn)
     1492#init_data * #calling' ** #EQcalling' whd in ⊢ (% → ?); cases(f_bl_r ?)
     1493[2,4: #x #y *] normalize nodelta #EQ destruct(EQ) * #_ #_ #_ #_ #_
     1494#_ #fresh_labs #_ #_ #_ #H lapply(H … EQstmt) -H * #lbls * #regs ** >EQlabels
     1495whd in ⊢ (??%? → ?); #EQ destruct(EQ) #EQregs cases stmt in EQstmt; normalize nodelta
     1496[3: * |2: * [#lbl || *] #EQstmt * #bl * whd in ⊢ (% → ?); cases regs in EQregs;
     1497    [2,4: #x #y #_ *] #EQregs normalize nodelta #EQ destruct(EQ) whd in ⊢ (%→?);
     1498    * #pref * #mid ** #EQmid whd in ⊢ (% → ?); * #EQ1 #EQ2 destruct(EQ1 EQ2)
     1499    whd in ⊢ (% → ?); #EQt_stmt
     1500| * [#c | * [#c_id|#c_ptr] #args #dest | #r #lbl | #seq ] #nxt #EQstmt
     1501  whd in ⊢ (% → ?); * #bl >if_merge_right [2,4,6,8,10: %] * whd in ⊢ (% → ?);
     1502  cases regs in  EQregs; normalize nodelta
     1503  [2,4,5,8,10: [1,2,4,5: #x #y] #_ *|6: #r * [2: #x #y] ]
     1504  #EQregs [1,2: whd in ⊢ (% → ?); [*]] #EQ destruct(EQ) whd in ⊢ (% → ?);
     1505  * #l1 * #mid1 * #mid2 * #l2 *** #EQmid1 whd in ⊢ (%→ ?);
     1506  [ * #mid * #rest ** #EQ destruct(EQ) whd in ⊢ (% → ?); * #nxt1 *
     1507    #EQlow change with nxt1 in ⊢ (??%? → ?); #EQ destruct(EQ)
     1508    whd in ⊢ (% → ?); * #mid3 * #rest1 ** #EQ destruct(EQ)
     1509     whd in EQmid1 : (???%); destruct(EQmid1) whd in e0 : (???%);
     1510     destruct(e0) ] * #EQ1 #EQ2 destruct(EQ1 EQ2) whd in EQmid1 : (???%);
     1511     destruct(EQmid1) whd in ⊢ (% → ?); * #nxt1 * #EQt_stmt #EQ destruct(EQ)
     1512     whd in ⊢ (% → ?); * #_ #EQ destruct(EQ)
     1513] whd in match get_sigma; normalize nodelta >code_block_of_block_eq >m_return_bind
     1514>EQfn >m_return_bind inversion(find ????)
     1515[1,3,5,7,9,11: #EQfind @⊥ lapply(find_none ?????? EQfind EQstmt) >EQlabels
     1516  normalize nodelta @eq_identifier_elim [1,3,5,7,9,11: #_ * |*: * #H #_ @H %]]
     1517* #lbl #s #EQfind >m_return_bind lapply(find_predicate ?????? EQfind)
     1518inversion(f_lbls ??) [1,3,5,7,9,11: #_ *] #l @(list_elim_left … l …)
     1519normalize nodelta [1,3,5,7,9,11: #_ @eq_identifier_elim
     1520                         [1,3,5,7,9,11: #EQ destruct(EQ) #_ % |*: #_ *]]
     1521#last #pre #_ #EQlbl >split_on_last_append normalize nodelta @eq_identifier_elim
     1522[2,4,6,8,10,12: #_ *] #EQ lapply EQlbl destruct(EQ) #EQlbl #_ @⊥
     1523lapply(fresh_labs lbl) >EQlbl whd in ⊢ (% → ?); #H lapply(append_All … H) -H
     1524* #_ whd in ⊢ (% → ?); *** #H #_ #_ @H -H @(code_is_in_universe … (pi2 ?? fn))
     1525whd in match code_has_label; whd in match code_has_point; normalize nodelta
     1526>EQstmt @I
     1527qed.
     1528
     1529lemma append_absurd : ∀A : Type[0]. ∀l : list A. ∀ a : A.
     1530l @ [a] = [ ] → False.
     1531#A * [2: #x #y] #a normalize #EQ destruct
     1532qed.
     1533
     1534lemma last_append_eq : ∀A : Type[0].∀l1,l2 : list A. ∀a1,a2: A.
     1535l1 @ [a1] = l2 @ [a2] → a1 = a2.
     1536#A #l1 elim l1 [ * [2: #hd #tl] #a1 #a2 normalize #EQ destruct [2: %]
     1537@⊥ lapply(sym_eq ??? e0) -e0 #e0 @(append_absurd ??? e0)] #hd #tl #IH
     1538* [ #a1 #a2 normalize #EQ destruct @⊥ @(append_absurd ??? e0)]
     1539#hd1 #tl1 #a1 #a2 normalize #EQ destruct(EQ) @(IH tl1 a1 a2 e0)
     1540qed.
     1541
     1542lemma get_sigma_last :
     1543∀prog : ertl_program.
     1544∀ f_lbls,f_regs.
     1545 ∀f_bl_r.
     1546 b_graph_transform_program_props ERTL_semantics ERTLptr_semantics
     1547     translate_data prog f_bl_r f_lbls f_regs →
     1548∀id,fn,bl,pt,stmt,pre,last.
     1549fetch_internal_function … (globalenv_noinit … prog) bl = return 〈id,fn〉 →
     1550stmt_at ERTL (prog_var_names … prog) (joint_if_code … fn) pt = return stmt → 
     1551f_lbls bl pt = return (pre@[last]) → get_sigma prog f_lbls bl last = return pt.
     1552#prog #f_lbls #f_regs #f_bl_r #good #id #fn #bl #pt #stmt #pre #last
     1553#EQfn #EQstmt #EQlabels
     1554cases(b_graph_transform_program_fetch_internal_function … good … EQfn)
     1555#init_data * #calling' ** #EQcalling' whd in ⊢ (% → ?); cases(f_bl_r ?)
     1556[2,4: #x #y *] normalize nodelta #EQ destruct(EQ) * #_ #_ #_ #_ #pp_labs
     1557#_ #fresh_labs #_ #_ #_ #H lapply(H … EQstmt) -H * #lbls * #regs ** >EQlabels
     1558whd in ⊢ (??%? → ?); #EQ destruct(EQ) #EQregs cases stmt in EQstmt; normalize nodelta
     1559[3: *
     1560|2: * [#lbl || *] #EQstmt whd in ⊢ (%→ ?); * #bl *
     1561|*: * [#c | * [ #c_id | #c_ptr] #args #dest | #r #lbl | #seq ] #nxt #EQstmt
     1562    >if_merge_right [2,4,6,8,10: %] whd in ⊢ (% → ?); * #bl *
     1563] whd in ⊢ (% → ?); cases regs in EQregs; normalize nodelta
     1564[2,4,6,8,9,12,14: [1,2,3,4,6,7: #x #y] #_ *|10: #r #tl] #EQregs
     1565[ whd in ⊢ (% → ?); cases tl in EQregs; normalize nodelta [2: #x #y #_ *] #EQregs]
     1566#EQbl destruct(EQbl) whd in ⊢ (%→?); [2,3: * #pref * #mid **|*: * #l1 * #mid1 * #mid2 * #l2 ***]
     1567#EQmid1 whd in ⊢ (% → ?);
     1568[1,2,4,5,6,7: * #EQ1 #EQ2 destruct(EQ1 EQ2) whd in EQmid1 : (??%%); destruct(EQmid1)
     1569[3,4,5,6: whd in ⊢ (% → ?); * #nxt1 * #EQt_stmt  #EQ destruct(EQ) ]
     1570whd in ⊢ (% → ?); * [1,2,3,4: #e0] @⊥ @(append_absurd ??? e0)]
     1571* #mid * #rest ** #EQ destruct(EQ) whd in ⊢ (% → ?); * #nxt1 * #_
     1572change with nxt1 in ⊢ (??%? → ?); #EQ destruct(EQ) whd in ⊢ (% → ?);
     1573* #mid3 * #rest1 ** #EQ destruct(EQ) whd in ⊢ (% → ?); * #nxt1 * #_
     1574change with nxt1 in ⊢ (??%? → ?); #EQ destruct(EQ) whd in ⊢ (% → ?);
     1575* #mid4 * #rest2 ** #EQ destruct(EQ)  whd in ⊢ (% → ?); * #nxt1 * #_
     1576change with nxt1 in ⊢ (??%? → ?); #EQ destruct(EQ) whd in ⊢ (% → ?);
     1577* #mid5 * #rest3 ** #EQ destruct(EQ) whd in ⊢ (% → ?); * #nxt1 * #_
     1578change with nxt1 in ⊢ (??%? → ?); #EQ destruct(EQ) whd in ⊢ (% → ?);
     1579* #EQ1 #EQ2 destruct(EQ1 EQ2) whd in ⊢ (% → ?); * #nxt1 * #EQcall
     1580change with nxt1 in ⊢ (??%? → ?); #EQ destruct(EQ) whd in ⊢ (% → ?);
     1581* #EQ1 #EQ2 destruct(EQ1 EQ2) whd in EQmid1 : (??%%); destruct(EQmid1)
     1582>e0 in EQlabels; #EQlabels whd in match get_sigma; normalize nodelta
     1583>code_block_of_block_eq >m_return_bind >EQfn >m_return_bind
     1584inversion(find ????)
     1585[ #EQfind @⊥ lapply(find_none ?????? EQfind EQstmt) >EQlabels
     1586  normalize nodelta @eq_identifier_elim [ #_ *] * #H #_ @H
     1587  whd in EQmid1 : (??%%); destruct(EQmid1) @(last_append_eq ????? e1) ]
     1588* #lbl #s #EQfind >m_return_bind lapply(find_predicate ?????? EQfind)
     1589inversion(f_lbls ??) [ #_ normalize nodelta *] #labels
     1590@(list_elim_left … labels …) -labels normalize nodelta
     1591[ #EQl @eq_identifier_elim [2: #_ *] #EQ lapply EQl destruct(EQ) #EQl
     1592  lapply(fresh_labs pt) >EQlabels <e0 whd in ⊢ (% → ?);
     1593  #H lapply(append_All … H) -H * #_ whd in ⊢ (% → ?); *** #H #_ #_ #_ @⊥ @H
     1594  @(code_is_in_universe … (pi2 ?? fn)) whd in match code_has_label;
     1595  whd in match code_has_point; normalize nodelta whd in match (stmt_at ????);
     1596  >(find_lookup ?????? EQfind) @I
     1597| #last1 #pre1 #_ #EQl >split_on_last_append normalize nodelta @eq_identifier_elim
     1598  [2: #_ *] #EQ lapply EQl destruct(EQ) #EQl #_ lapply pp_labs
     1599  whd in match partial_partition; normalize nodelta * #_ #H lapply(H lbl pt)
     1600  >EQl <e0 in EQlabels; #EQlabels >EQlabels whd in ⊢ (% → ?); -H #H
     1601  >(H last1 ? ?) [%] >(memb_append_l2 ? last1 ? [last1] ?) /2 by /
     1602]
     1603qed.
     1604
     1605lemma fetch_call_commute :
     1606∀prog : ertl_program.
     1607let trans_prog ≝ ertl_to_ertlptr prog in
     1608∀ f_lbls,f_regs.
     1609 ∀f_bl_r.
     1610 b_graph_transform_program_props ERTL_semantics ERTLptr_semantics
     1611     translate_data prog f_bl_r f_lbls f_regs →
     1612∀id,fn,c_id,c_args,c_dest,nxt,pc.
     1613fetch_statement ERTL_semantics
     1614    (prog_var_names … prog) (globalenv_noinit … prog) pc =
     1615    return 〈id,fn, sequential ? ?(CALL ERTL_semantics ? c_id c_args c_dest) nxt〉 →
     1616∃fn',pc'. sigma_stored_pc prog f_lbls pc' = pc ∧
     1617fetch_statement ERTLptr_semantics
     1618    (prog_var_names … trans_prog) (globalenv_noinit … trans_prog) pc' =
     1619return 〈id,fn', sequential ? ?(CALL ERTLptr_semantics ? c_id c_args c_dest) nxt〉.
     1620#prog #f_lbls #f_regs #f_bl_r #good #id #fn * [ #c_id | #c_ptr ] #c_args #c_dest
     1621#nxt #pc #EQfetch lapply(fetch_statement_inv … EQfetch) * #EQfn #EQstmt
     1622cases(b_graph_transform_program_fetch_internal_function … good … EQfn)
     1623#init_data * #calling' ** #EQcalling' whd in ⊢ (% → ?); cases(f_bl_r ?)
     1624[2,4: #x #y *] normalize nodelta #EQ destruct(EQ) * #_ #_ #_ #_ #pp_labs
     1625#_ #fresh_labs #_ #_ #_ #H cases(H … EQstmt) -H #labels * #registers
     1626** #EQlabels #EQregisters normalize nodelta >if_merge_right [2,4: %]
     1627whd in match translate_step;
     1628normalize nodelta whd in ⊢ (% → ?); * #bl * whd in ⊢ (% → ?);
     1629cases registers in EQregisters; -registers normalize nodelta
     1630[2,3: [ #x #y] #_ *|4: #r #tl] #EQregisters
     1631[ whd in ⊢ (% → ?); cases tl in EQregisters; -tl [2: #x #y #_ *] normalize nodelta
     1632#EQregisters] #EQ destruct(EQ) whd in ⊢ (% → ?); *
     1633#pre_l * #mid1 * #mid2 * #post_l *** #EQmid1 whd in ⊢ (% → ?);
     1634[ * #mid * #resg ** #EQ destruct(EQ) whd in ⊢ (% → ?);
     1635  * #nxt1 * #EQlow change with nxt1 in ⊢ (??%? → ?); #EQ destruct(EQ)
     1636  whd in ⊢ (% → ?); * #mid3 * #rest1 ** #EQ destruct(EQ) * #nxt1 *
     1637  #EQpush1 change with nxt1 in ⊢ (??%? → ?); #EQ destruct(EQ)
     1638  whd in ⊢ (% → ?); * #mid4 * #rest2 ** #EQ destruct(EQ) * #nxt1 * #EQhigh
     1639  change with nxt1 in ⊢ (??%? → ?); #EQ destruct(EQ) whd in ⊢ (% → ?);
     1640  * #mid5 * #rest3 ** #EQ destruct(EQ) * #nxt1 * #EQpush2
     1641  change with nxt1 in ⊢ (??%? → ?); #EQ destruct(EQ) whd in ⊢ (% → ?);
     1642] * #EQ1 #EQ2 destruct(EQ1 EQ2) whd in EQmid1 : (??%%); destruct(EQmid1)
     1643whd in ⊢ (% → ?); * #nxt1 * #EQcall #EQ destruct(EQ) whd in ⊢ (% → ?);
     1644* #EQ destruct(EQ) change with nxt1 in ⊢ (??%? → ?); #EQ destruct(EQ)
     1645%{calling'}
     1646[  %{(pc_of_point ERTLptr_semantics (pc_block pc) mid1)}
     1647|  %{pc}
     1648] %
     1649[1,3: whd in match sigma_stored_pc; whd in match sigma_pc_opt; normalize nodelta
     1650      @eqZb_elim change with (pc_block pc) in match (pc_block ?) in ⊢ (% → ?);
     1651      [1,3: #EQbl >fetch_internal_function_no_minus_one in EQfn; try assumption
     1652            #EQ destruct(EQ)] #_ normalize nodelta
     1653            [2: >(get_sigma_idempotent … good … EQfn EQstmt EQlabels)
     1654            |*: change with (pc_block pc) in match (pc_block ?);
     1655                >point_of_pc_of_point >(get_sigma_last … good … EQfn EQstmt EQlabels)
     1656            ] >m_return_bind normalize nodelta >pc_of_point_of_pc %
     1657|*: whd in match fetch_statement; normalize nodelta >EQcalling' >m_return_bind
     1658    [>point_of_pc_of_point ] >EQcall %
     1659]
    18471660qed.
    18481661
    1849 lemma pc_block_eq : ∀prog : ertl_program.
    1850 ∀sigma : sigma_map prog.
    1851 ∀pc,id,fn.
    1852 fetch_internal_function (joint_closed_internal_function ERTL
    1853   (prog_var_names (joint_function ERTL) ℕ prog))
    1854   (globalenv_noinit (joint_function ERTL) prog) (pc_block … pc)
    1855   = return 〈id,fn〉→
    1856 sigma fn (point_of_pc ERTL_semantics pc) ≠ None ? →
    1857  pc_block … pc = pc_block … (sigma_stored_pc prog sigma pc).
    1858 #prog #sigma * #bl #pos #id #fn #EQfn #EQlbl whd in match sigma_stored_pc;
    1859 normalize nodelta whd in match sigma_pc_opt; normalize nodelta @if_elim [ #_ %]
    1860 #_ >EQfn >m_return_bind >(opt_to_opt_safe … EQlbl) >m_return_bind %
    1861 qed.
     1662
     1663
     1664lemma next_of_call_pc_ok : ∀prog : ertl_program.
     1665let trans_prog ≝ ertl_to_ertlptr prog in
     1666∀ f_lbls,f_regs.∀f_bl_r.
     1667b_graph_transform_program_props ERTL_semantics ERTLptr_semantics
     1668     translate_data prog f_bl_r f_lbls f_regs →
     1669∀pc,lb.
     1670next_of_call_pc ERTL_semantics (prog_var_names … prog) (globalenv_noinit … prog)
     1671  pc = return lb →
     1672∃pc'. sigma_stored_pc prog f_lbls pc' = pc ∧ 
     1673next_of_call_pc ERTLptr_semantics (prog_var_names … trans_prog)
     1674             (globalenv_noinit … trans_prog) pc' =  return lb.
     1675#prog #f_lbls #f_regs #f_bl_r #good #pc #lb whd in match next_of_call_pc;
     1676normalize nodelta #H @('bind_inversion H) -H ** #id #fn
     1677*  [ *[ #c | #c_id #c_arg #c_dest | #reg #lbl | #seq ] #prox | #fin | *]
     1678#EQfetch normalize nodelta whd in ⊢ (??%% → ?); #EQ destruct(EQ)
     1679cases(fetch_call_commute … good … EQfetch) #fn1 * #pc1 * #EQpc1 #EQt_fetch
     1680%{pc1} % [assumption] >EQt_fetch %
     1681qed.
     1682
     1683lemma next_of_call_pc_error : ∀pars.∀prog : program ? ℕ. ∀init,pc.
     1684(block_id (pi1 … (pc_block pc)) = 0 ∨ block_id (pi1 … (pc_block pc)) = -1) →
     1685next_of_call_pc pars (prog_var_names … prog) (globalenv … init prog)
     1686  pc = Error ? [MSG BadFunction].
     1687#pars #prg #init #pc * #EQ whd in match next_of_call_pc; normalize nodelta
     1688whd in match fetch_statement; normalize nodelta
     1689[ >fetch_internal_function_no_zero | >fetch_internal_function_no_minus_one]
     1690//
     1691qed.
     1692
     1693lemma next_of_call_pc_inv :  ∀pars.∀prog : program ? ℕ. ∀init.
     1694∀pc,nxt.
     1695next_of_call_pc pars (prog_var_names … prog)
     1696(globalenv … init prog) pc = return nxt →
     1697∃id,fn,c_id,c_args,c_dest.
     1698fetch_statement pars
     1699    (prog_var_names … prog) (globalenv … init prog) pc =
     1700    return 〈id,fn, sequential ? ?(CALL pars ? c_id c_args c_dest) nxt〉.
     1701#pars #prog #init #pc #nxt whd in match next_of_call_pc; normalize nodelta
     1702#H @('bind_inversion H) -H ** #id #fn *
     1703[ *[ #c | #c_id #c_arg #c_dest | #reg #lbl | #seq ] #prox | #fin | #H #r #l #l ]
     1704#EQfetch normalize nodelta whd in ⊢ (??%% → ?); #EQ destruct(EQ)
     1705%{id} %{fn} %{c_id} %{c_arg} %{c_dest} assumption
     1706qed.
     1707
     1708lemma sigma_stored_pc_inj : ∀ prog : ertl_program.
     1709∀f_lbls,pc,pc'. sigma_pc_opt prog f_lbls pc ≠ None ? →
     1710sigma_pc_opt prog f_lbls pc = sigma_pc_opt prog f_lbls pc' →
     1711pc = pc'.
     1712#prog #f_lbls ** #id #EQblid #off ** #id' #EQblid' #off'
     1713* inversion(sigma_pc_opt ???) [#_ #H @⊥ @H %]
     1714#pc1 whd in match sigma_pc_opt; normalize nodelta @if_elim
     1715[ @eqZb_elim [2: #_ *] #EQbl * whd in ⊢ (??%? → ?); #EQ destruct #_
     1716#H lapply(sym_eq ??? H) -H @if_elim [#_ whd in ⊢ (??%? → ?); #EQ destruct %]
     1717@eqZb_elim [ #_ *] * #EQbl' #_ #H @('bind_inversion H) -H #lb #EQlb
     1718whd in ⊢ (??%? → ?); #EQ destruct @⊥ @EQbl' assumption] @eqZb_elim [#_ *] * #EQbl #_
     1719#H @('bind_inversion H) -H * #lb #EQlb whd in ⊢ (??%? → ?); #EQ destruct #_
     1720#H lapply(sym_eq ??? H) -H @if_elim
     1721[ @eqZb_elim [2: #_ *] #EQbl' #_ whd in ⊢ (??%? → ?); #EQ destruct @⊥ @EQbl @EQbl']
     1722#_ #H @('bind_inversion H) -H * #lb' #EQlb' whd in ⊢ (??%? → ?);
     1723whd in match (pc_of_point ???); whd in match (offset_of_point ??);
     1724whd in match (offset_of_point ??); #EQ destruct @eq_f
     1725cut(an_identifier LabelTag off = an_identifier LabelTag off') [2: #EQ destruct %]
     1726@(partial_inj_sigma prog f_lbls id) [>EQlb % #ABS destruct | >EQlb >EQlb' %]
     1727qed.
     1728
     1729lemma eval_return_ok :
     1730∀prog : ertl_program.
     1731let trans_prog ≝ ertl_to_ertlptr prog in
     1732∀ f_lbls,f_regs,stack_sizes.
     1733 ∀f_bl_r.
     1734 ∀ good :b_graph_transform_program_props ERTL_semantics ERTLptr_semantics
     1735     translate_data prog f_bl_r f_lbls f_regs.
     1736∀st2, st1',f,fn.
     1737 let st1 ≝ sigma_state_pc prog f_lbls f_regs st2 in
     1738 fetch_statement ERTL_semantics …
     1739  (globalenv_noinit ? prog) (pc … st1) =
     1740    return 〈f, fn,  final … (RETURN ERTL … )〉 →
     1741 eval_state ERTL_semantics
     1742   (prog_var_names (joint_function ERTL_semantics) ℕ prog)
     1743   (ev_genv … (mk_prog_params ERTL_semantics prog stack_sizes))
     1744   st1 =
     1745  return st1' →
     1746joint_classify (mk_prog_params ERTLptr_semantics trans_prog stack_sizes)
     1747  st2 = cl_return ∧
     1748∃st2'. st1' = sigma_state_pc prog f_lbls f_regs st2' ∧
     1749∃st2_after_ret.
     1750∃taf : trace_any_any_free (ERTLptr_status trans_prog stack_sizes) (* always empty in this case *)
     1751st2_after_ret
     1752st2'.
     1753(if taaf_non_empty … taf then
     1754  ¬as_costed (ERTLptr_status trans_prog stack_sizes)
     1755    st2_after_ret
     1756 else True) ∧
     1757eval_state … (ev_genv …  (mk_prog_params ERTLptr_semantics trans_prog stack_sizes)) st2 =
     1758return st2_after_ret ∧
     1759ret_rel ?? (ERTLptrStatusSimulation prog stack_sizes ??? good) st1' st2_after_ret.
     1760#prog #f_lbls #f_regs #stack_size #f_bl_r #good #st2 #st1' #f #fn #EQfetch
     1761whd in match eval_state; normalize nodelta >EQfetch >m_return_bind
     1762#H @('bind_inversion H) -H #st1_tmp whd in ⊢ (??%%→?); #EQ destruct
     1763whd in match set_no_pc in ⊢ (%→?); whd in match eval_statement_advance in ⊢ (%→?);
     1764whd in match eval_return; normalize nodelta #H lapply(err_eq_from_io ????? H) -H
     1765#H @('bind_inversion H) -H * #n_st #n_pc change with (ertl_pop_frame ? = ? → ?)
     1766>(fetch_stmt_ok_sigma_state_ok … EQfetch) #EQpop_frame
     1767cases(pop_frame_ok ?????? EQpop_frame) * #t_n_st #t_n_pc * #EQt_pop_frame
     1768normalize nodelta
     1769inversion (fetch_internal_function ??) normalize nodelta
     1770[ * #id1 #fn1 | #err ] normalize nodelta #EQfetch_fn1 #EQ destruct(EQ)
     1771#H @('bind_inversion H) -H #next_of_n_pc
     1772[2: >next_of_call_pc_error [2: % %] whd in ⊢ (???% → ?); #EQ destruct(EQ)]
     1773#EQnext_of_n_pc cases(next_of_call_pc_ok … good … EQnext_of_n_pc)
     1774#pc1 * #EQpc1 cut(pc1 = t_n_pc)
     1775[ @(sigma_stored_pc_inj prog f_lbls)
     1776  lapply EQnext_of_n_pc; <EQpc1 whd in match sigma_stored_pc; normalize nodelta
     1777  inversion(sigma_pc_opt ???) [1,3: #_ >next_of_call_pc_error [2,4: % %]
     1778  whd in ⊢ (???% → ?); #EQ destruct| #x #_ #_ % #EQ destruct] #x #EQx #_
     1779  lapply EQnext_of_n_pc whd in match sigma_stored_pc; normalize nodelta
     1780  inversion (sigma_pc_opt ???) [ #_ >next_of_call_pc_error [2: % %]
     1781  whd in ⊢ (???% → ?); #EQ destruct] #y #EQy #_ lapply EQpc1
     1782  whd in match sigma_stored_pc; normalize nodelta >EQx >EQy normalize nodelta
     1783  #EQ destruct %
     1784] #EQ destruct(EQ) #EQnxt whd in match next; whd in match set_last_pop;
     1785whd in match set_pc; normalize nodelta whd in ⊢ (??%% → ?); #EQ destruct(EQ)
     1786cases(b_graph_transform_program_fetch_statement … good … EQfetch)
     1787#init_data * #t_fn1 ** #EQt_fn1 whd in ⊢ (% → ?); cases (f_bl_r ?) normalize nodelta
     1788[2: #r #tl *] #EQ destruct(EQ) * #labs **
     1789[2: #hd #tl ** #_ #_ * #ibl * whd in ⊢ (%→?); *] ** #EQlabs #EQf_regs
     1790whd in match translate_fin_step; normalize nodelta * #bl *
     1791whd in ⊢ (% → ?); #EQ destruct(EQ) **
     1792[2: #lb #tl * #mid ** #EQmid whd in ⊢ (% → ?); * #ABS destruct(ABS)] * #mid **
     1793whd in ⊢ (???% → ?); #EQ destruct(EQ) * #_ #_ change with (stmt_at ???? = ? → ?)
     1794#EQstmt %
     1795[ whd in match joint_classify; normalize nodelta whd in match fetch_statement;
     1796  normalize nodelta <(fetch_stmt_ok_sigma_pc_ok … EQfetch) >EQt_fn1 >m_return_bind
     1797  >EQstmt %
     1798| %
     1799    [ %
     1800        [ @t_n_st
     1801        | @(succ_pc ERTL_semantics (sigma_stored_pc prog f_lbls t_n_pc) next_of_n_pc)
     1802        | @t_n_pc]
     1803    ]
     1804  % 
     1805    [ whd in match sigma_state_pc; normalize nodelta
     1806      lapply(next_of_call_pc_inv … EQnext_of_n_pc) * #id2 * #fn2 * #c_id * #c_arg
     1807      * #c_dest #EQfetch1 whd in match (succ_pc ???);
     1808      >(fetch_stmt_ok_sigma_pc_block_ok … EQfetch1) >EQfetch_fn1
     1809      normalize nodelta %
     1810    ]
     1811  %
     1812    [ %
     1813        [ @t_n_st
     1814        | @(succ_pc ERTL_semantics (sigma_stored_pc prog f_lbls t_n_pc) next_of_n_pc)
     1815        | @t_n_pc]
     1816    ]
     1817  %{(taaf_base … )} normalize nodelta % [% [@I]]
     1818    [ whd in match fetch_statement; normalize nodelta <(fetch_stmt_ok_sigma_pc_ok … EQfetch)
     1819      >EQt_fn1 >m_return_bind >EQstmt >m_return_bind whd in match eval_statement_no_pc;
     1820      normalize nodelta >m_return_bind whd in match eval_statement_advance;
     1821      whd in match eval_return; normalize nodelta 
     1822      change with (ertl_pop_frame ?) in match (pop_frame ????????);
     1823      >EQt_pop_frame >m_return_bind >EQnxt >m_return_bind whd in match next;
     1824      whd in match set_pc; whd in match set_last_pop; whd in match succ_pc;
     1825      normalize nodelta lapply(next_of_call_pc_inv … EQnext_of_n_pc)
     1826      * #id2 * #fn2 * #c_id * #c_arg * #c_dest #EQfetch1 whd in match (succ_pc ???);
     1827      >(fetch_stmt_ok_sigma_pc_block_ok … EQfetch1) %
     1828    | whd * #s1_pre #s1_call
     1829      cases (joint_classify_call … s1_call)
     1830      * #calling_i #calling * #call_spec * #arg * #dest * #nxt' #EQfetch_call
     1831      * #s2_pre #s2_call whd in ⊢ (% → ?); >EQfetch_call normalize nodelta
     1832      * #s1_pre_prf #EQpc_s2_pre whd in ⊢ (% → ?); #EQ1
     1833      >EQ1 in EQfetch_call; #EQfetch_call
     1834      cases(fetch_call_commute … good … EQfetch_call) #calling' * #pc1 *
     1835      #EQ1 cut(pc … s2_pre = pc1)
     1836      [ @(sigma_stored_pc_inj prog f_lbls) lapply(EQfetch_call)
     1837        whd in match sigma_stored_pc; normalize nodelta inversion(sigma_pc_opt ???)
     1838        [1,3: #_ >fetch_statement_no_zero [2,4: %] #EQ destruct(EQ)| #x #_ #_ % #EQ destruct]
     1839        #pc2 #EQpc2 #_ lapply EQ1 whd in match sigma_stored_pc;
     1840        normalize nodelta >EQpc2 normalize nodelta cases(sigma_pc_opt ???)
     1841        [2: #x normalize nodelta #EQ >EQ %] normalize nodelta #EQ <EQ in EQpc2;
     1842        #EQ1 lapply EQfetch_call >fetch_statement_no_zero [ #ABS destruct(ABS)]
     1843        whd in match sigma_stored_pc; normalize nodelta >EQ1 %
     1844      ] #EQ2 destruct(EQ2) #EQt_fetch_call whd >EQt_fetch_call normalize nodelta %
     1845       [ >EQ1 in s1_pre_prf; #EQ @(sigma_stored_pc_inj prog f_lbls)
     1846        lapply EQnext_of_n_pc whd in match sigma_stored_pc; normalize nodelta
     1847        inversion(sigma_pc_opt ???) [1,3: #_ >next_of_call_pc_error [2,4: % %]
     1848        whd in ⊢ (???% → ?); #EQ destruct] #pc1 #EQpc1 #_ [ % #EQ destruct]
     1849        lapply EQ whd in match sigma_stored_pc; normalize nodelta
     1850        >EQpc1 normalize nodelta inversion(sigma_pc_opt ???)
     1851        [2: #pc2 #_ normalize nodelta #EQ >EQ %] normalize nodelta
     1852        #ABS #ABS1 lapply EQnext_of_n_pc whd in match sigma_stored_pc;
     1853        normalize nodelta >EQpc1 >ABS1 normalize nodelta
     1854        >next_of_call_pc_error [2: % %] whd in ⊢ (???% → ?); #EQ destruct
     1855       | whd in match succ_pc; normalize nodelta
     1856        change with next_of_n_pc in match (point_of_succ ???);
     1857        change with nxt' in match (point_of_succ ???);
     1858        lapply EQpc_s2_pre whd in match succ_pc; normalize nodelta
     1859        change with next_of_n_pc in match (point_of_succ ???);
     1860        change with nxt' in match (point_of_succ ???); #EQ >EQ
     1861        cut(pc_block (pc … s1_pre) = pc_block (pc … s2_pre))
     1862        [2: #EQ >EQ %] >EQ1 <(pc_block_eq prog f_lbls …) [%]
     1863        lapply EQfetch_call whd in match sigma_stored_pc; normalize nodelta
     1864        cases(sigma_pc_opt ???) [ >fetch_statement_no_zero [2: %] #EQ destruct]
     1865        #x #_ % #EQ destruct
     1866       ]
     1867     ]
     1868]
     1869qed.
     1870
     1871lemma bool_of_beval_ok : ∀prog : ertl_program.
     1872∀f_lbls. preserving1 … res_preserve1 …
     1873              (sigma_beval prog f_lbls)
     1874              (λx.x)
     1875              (bool_of_beval)
     1876              (bool_of_beval).
     1877#prog #f_lbls * [ | | #ptr1 #ptr2 #p | #by | #p | #ptr #p | #pc1 #p1]
     1878whd in match bool_of_beval; normalize nodelta try @res_preserve_error1
     1879try @mfr_return1 whd in match sigma_beval; normalize nodelta
     1880cases (sigma_pc_opt ???) normalize nodelta [2: #pc] @res_preserve_error1
     1881qed.
     1882
     1883lemma eval_cond_ok :
     1884∀prog.
     1885let trans_prog ≝ ertl_to_ertlptr prog in
     1886∀ f_lbls,f_regs,stack_sizes.
     1887 ∀f_bl_r.
     1888 ∀ good :b_graph_transform_program_props ERTL_semantics ERTLptr_semantics
     1889     translate_data prog f_bl_r f_lbls f_regs.
     1890∀st2,st1',f,fn,a,ltrue,lfalse.
     1891let st1 ≝ sigma_state_pc prog f_lbls f_regs st2 in
     1892 fetch_statement ERTL_semantics …
     1893  (globalenv_noinit ? prog) (pc … st1) =
     1894    return 〈f, fn,  sequential … (COND ERTL … a ltrue) lfalse〉 →
     1895 eval_state ERTL_semantics
     1896   (prog_var_names (joint_function ERTL_semantics) ℕ prog)
     1897   (ev_genv … (mk_prog_params ERTL_semantics prog stack_sizes))
     1898   st1 = return st1' →
     1899as_costed (ERTL_status prog stack_sizes) st1' →
     1900∃ st2'. st1' = sigma_state_pc prog f_lbls f_regs st2' ∧
     1901∃taf : trace_any_any_free (ERTLptr_status trans_prog stack_sizes)
     1902st2 st2'.
     1903bool_to_Prop (taaf_non_empty … taf).
     1904#prog #f_lbls #f_regs #stack_size #f_bl_r #good #st2 #st1' #f #fn #a #ltrue #lfalse
     1905#EQfetch whd in match eval_state; normalize nodelta >EQfetch >m_return_bind
     1906whd in match eval_statement_no_pc; normalize nodelta >m_return_bind
     1907whd in match eval_statement_advance; normalize nodelta
     1908change with (ps_reg_retrieve ??) in match (acca_retrieve ?????);
     1909#H lapply(err_eq_from_io ????? H) -H #H @('bind_inversion H) -H
     1910#bv >(fetch_stmt_ok_sigma_state_ok … EQfetch) in ⊢ (% → ?); whd in match set_no_pc;
     1911normalize nodelta #EQbv #H @('bind_inversion H) -H * #EQbool normalize nodelta
     1912 lapply(fetch_statement_inv … EQfetch) * #EQfn #_
     1913[ whd in match goto; normalize nodelta >(pc_of_label_eq ??????? EQfn) >m_return_bind
     1914| whd in match next; normalize nodelta
     1915] whd in match set_pc; normalize nodelta
     1916>(fetch_stmt_ok_sigma_state_ok … EQfetch) whd in match set_no_pc; normalize nodelta
     1917>(fetch_stmt_ok_sigma_pc_ok … EQfetch) >(fetch_stmt_ok_sigma_last_pop_ok … EQfetch)
     1918whd in ⊢ (??%% → ?); #EQ destruct #n_cost
     1919%{(mk_state_pc ? (st_no_pc … st2)
     1920                 (pc_of_point ERTLptr_semantics (pc_block (pc … st2)) ?)
     1921                 (last_pop … st2))} [ @ltrue |3: @lfalse]
     1922% [1,3: whd in match sigma_state_pc; normalize nodelta
     1923        >(fetch_stmt_ok_sigma_pc_ok … EQfetch) in EQfn; #EQfn >EQfn %]
     1924cases(b_graph_transform_program_fetch_statement … good … EQfetch)
     1925#init_data * #t_fn1 ** #EQt_fn1 whd in ⊢ (% → ?); cases (f_bl_r ?) normalize nodelta
     1926[2,4: #r #tl *] #EQ destruct(EQ) >if_merge_right in ⊢ (% → ?); [2,4: %] * #labs **
     1927[2,4: #hd #tl ** #_ #_ *** #pre #inst #post * whd in ⊢ (%→?); *] ** #EQlabs #EQf_regs
     1928whd in match translate_step; normalize nodelta * #bl *
     1929whd in ⊢ (% → ?); #EQ destruct(EQ) whd in ⊢ (% → ?); * #l1 * #mid1 * #mid2 * #l2
     1930*** #EQmid1 whd in ⊢ (% → ?); * #EQ1 #EQ2 destruct(EQ1 EQ2) whd in ⊢ (% → ?); *
     1931#nxt1 * #EQcond #EQ destruct(EQ) whd in ⊢ (% → ?); * #EQ1 #EQ2 destruct(EQ1 EQ2)
     1932whd in EQmid1 : (??%%); destruct(EQmid1)
     1933%{(taaf_step_jump … (taa_base …) …) I}
     1934[2,5: whd whd in ⊢ (??%?); whd in match fetch_statement; normalize nodelta 
     1935      <(fetch_stmt_ok_sigma_pc_ok … EQfetch) >EQt_fn1 >m_return_bind
     1936      >EQcond %
     1937|3,6: whd whd in match eval_state; normalize nodelta whd in match eval_statement_no_pc;
     1938      normalize nodelta whd in match fetch_statement; normalize nodelta
     1939      <(fetch_stmt_ok_sigma_pc_ok … EQfetch) >EQt_fn1 >m_return_bind
     1940      >EQcond >m_return_bind normalize nodelta >m_return_bind
     1941      whd in match eval_statement_advance; normalize nodelta
     1942      change with (ps_reg_retrieve ??) in match (acca_retrieve ?????);
     1943      cases(ps_reg_retrieve_ok … EQbv) #bv1 * #EQbv1 #EQsem >EQbv1
     1944      >m_return_bind >EQsem in EQbool; #EQbool cases(bool_of_beval_ok … EQbool)
     1945      #bool1 * #EQbool1 #EQ destruct(EQ) >EQbool1 >m_return_bind normalize nodelta
     1946      >(fetch_stmt_ok_sigma_pc_ok … EQfetch) [2: %] whd in match goto;
     1947      normalize nodelta >(fetch_stmt_ok_sigma_pc_ok … EQfetch) in EQt_fn1; #EQt_fn1
     1948      >(pc_of_label_eq … EQt_fn1) >m_return_bind %
     1949|*: lapply n_cost whd in match as_costed; normalize nodelta
     1950    [ cut((mk_state_pc ERTL_semantics
     1951   (sigma_state prog f_lbls f_regs
     1952    (added_registers ERTL (prog_var_names (joint_function ERTL) ℕ prog) fn
     1953     (f_regs (pc_block (pc ERTLptr_semantics st2)))) st2)
     1954   (pc_of_point ERTL_semantics (pc_block (pc ERTLptr_semantics st2)) ltrue)
     1955   (sigma_stored_pc prog f_lbls (last_pop ERTLptr_semantics st2))) =
     1956   sigma_state_pc prog f_lbls f_regs (mk_state_pc ERTLptr_semantics st2
     1957    (pc_of_point ERTLptr_semantics (pc_block (pc ERTLptr_semantics st2)) ltrue)
     1958    (last_pop ERTLptr_semantics st2))) [ whd in match sigma_state_pc; normalize  nodelta
     1959    >(fetch_stmt_ok_sigma_pc_ok … EQfetch) in EQfn; #EQfn >EQfn %]
     1960    #EQ >EQ >(as_label_ok … good … (mk_state_pc ERTLptr_semantics st2
     1961    (pc_of_point ERTLptr_semantics (pc_block (pc ERTLptr_semantics st2)) ltrue)
     1962    (last_pop ERTLptr_semantics st2))) [#H @H] cases daemon (*needs lemma see below *)
     1963    | cut((mk_state_pc ERTL_semantics
     1964   (sigma_state prog f_lbls f_regs
     1965    (added_registers ERTL (prog_var_names (joint_function ERTL) ℕ prog) fn
     1966     (f_regs (pc_block (pc ERTLptr_semantics st2)))) st2)
     1967   (succ_pc ERTL_semantics (pc ERTLptr_semantics st2)
     1968    (point_of_succ ERTLptr_semantics
     1969     (point_of_pc ERTLptr_semantics
     1970      (pc ERTL_semantics (sigma_state_pc prog f_lbls f_regs st2))) nxt1))
     1971   (sigma_stored_pc prog f_lbls (last_pop ERTLptr_semantics st2))) =
     1972   sigma_state_pc prog f_lbls f_regs (mk_state_pc ERTLptr_semantics st2
     1973    (pc_of_point ERTLptr_semantics (pc_block (pc ERTLptr_semantics st2))
     1974     (point_of_succ ERTLptr_semantics
     1975      (point_of_pc ERTLptr_semantics
     1976       (pc ERTL_semantics (sigma_state_pc prog f_lbls f_regs st2))) nxt1))
     1977    (last_pop ERTLptr_semantics st2))) [ whd in match sigma_state_pc; normalize  nodelta
     1978    >(fetch_stmt_ok_sigma_pc_ok … EQfetch) in EQfn; #EQfn >EQfn %] #EQ >EQ
     1979    >(as_label_ok … good … (mk_state_pc ERTLptr_semantics st2
     1980    (pc_of_point ERTLptr_semantics (pc_block (pc ERTLptr_semantics st2))
     1981     (point_of_succ ERTLptr_semantics
     1982      (point_of_pc ERTLptr_semantics
     1983       (pc ERTL_semantics (sigma_state_pc prog f_lbls f_regs st2))) nxt1))
     1984    (last_pop ERTLptr_semantics st2))) [#H @H] cases daemon (*needs lemma see below ! *)
     1985]
     1986qed.
     1987     
     1988lemma eval_cost_ok :
     1989∀prog.
     1990let trans_prog ≝ ertl_to_ertlptr prog in
     1991∀ f_lbls,f_regs,stack_sizes.
     1992 ∀f_bl_r.
     1993 ∀ good :b_graph_transform_program_props ERTL_semantics ERTLptr_semantics
     1994     translate_data prog f_bl_r f_lbls f_regs.
     1995∀st2,st1',f,fn,c,nxt.
     1996let st1 ≝ sigma_state_pc prog f_lbls f_regs st2 in
     1997 fetch_statement ERTL_semantics …
     1998  (globalenv_noinit ? prog) (pc … st1) =
     1999    return 〈f, fn,  sequential … (COST_LABEL ERTL … c) nxt〉 →
     2000 eval_state ERTL_semantics
     2001   (prog_var_names (joint_function ERTL_semantics) ℕ prog)
     2002   (ev_genv … (mk_prog_params ERTL_semantics prog stack_sizes))
     2003   st1 = return st1' →
     2004∃ st2'. st1' = sigma_state_pc prog f_lbls f_regs st2' ∧
     2005∃taf : trace_any_any_free (ERTLptr_status trans_prog stack_sizes)
     2006st2 st2'.
     2007bool_to_Prop (taaf_non_empty … taf).
     2008#prog #f_lbls #f_regs #stack_Size #f_bl_r #good #st2 #st1' #f #fn #c #nxt
     2009#EQfetch whd in match eval_state; normalize nodelta >EQfetch >m_return_bind
     2010whd in match eval_statement_no_pc; normalize nodelta >m_return_bind
     2011whd in match eval_statement_advance; normalize nodelta
     2012>(fetch_stmt_ok_sigma_state_ok … EQfetch) whd in match set_no_pc;
     2013normalize nodelta >(fetch_stmt_ok_sigma_pc_ok … EQfetch)
     2014>(fetch_stmt_ok_sigma_last_pop_ok … EQfetch) whd in match next;
     2015whd in match set_pc; normalize nodelta whd in ⊢ (??%% → ?); #EQ destruct(EQ)
     2016%{(set_pc ? (pc_of_point ERTLptr_semantics (pc_block (pc … st2)) nxt) st2)}
     2017% [ whd in match sigma_state_pc; normalize nodelta
     2018    lapply(fetch_statement_inv … EQfetch) >(fetch_stmt_ok_sigma_pc_ok … EQfetch) *
     2019    #EQfn #_ >EQfn %] lapply EQfetch >(fetch_stmt_ok_sigma_pc_ok … EQfetch)
     2020#EQfetch'
     2021cases(b_graph_transform_program_fetch_statement … good … EQfetch')
     2022#init_data * #t_fn ** #EQt_fn whd in ⊢ (% → ?); cases(f_bl_r ?) [2: #x #y *]
     2023normalize nodelta #EQ destruct(EQ) * #lbls * #regs ** #_ #_ whd in ⊢ (% → ?);
     2024* #bl * >if_merge_right [2: %] whd in ⊢ (% → ?); cases regs [2: #x #y *]
     2025normalize nodelta #EQ destruct(EQ) whd in ⊢ (% → ?); * #l1 * #mid1 * #mid2 * #l2
     2026*** #EQmid whd in ⊢ (% → ?); * #EQ1 #EQ2 destruct(EQ1 EQ2) whd in EQmid : (???%);
     2027destruct(EQmid) whd in ⊢ (% → ?); * #nxt1 * #EQstmt #EQ destruct(EQ)
     2028whd in ⊢ (% → ?); * #EQ1 #EQ2 destruct(EQ1 EQ2) %{(taaf_step … (taa_base …) …)}
     2029[1,2: whd [ whd in ⊢ (??%?); | whd in match eval_state; ] 
     2030      whd in match fetch_statement; normalize nodelta >EQt_fn >m_return_bind
     2031      >EQstmt [%] >m_return_bind whd in match eval_statement_no_pc;
     2032      normalize nodelta >m_return_bind %] @I
     2033qed.
     2034
     2035lemma block_of_call_ok : ∀prog: ertl_program.
     2036 let trans_prog ≝ ertl_to_ertlptr prog in
     2037 ∀ f_lbls,f_regs.
     2038∀called,restr. preserving1 … res_preserve1 …
     2039              (sigma_state prog f_lbls f_regs restr)
     2040              (λx.x)
     2041              (block_of_call ERTL_semantics (prog_var_names … prog)
     2042                      (globalenv_noinit … prog) called)
     2043              (block_of_call ERTLptr_semantics (prog_var_names … trans_prog)
     2044                      (globalenv_noinit … trans_prog) called).
     2045#prog #f_lbls #f_regs #called #restr #st whd in match block_of_call; normalize nodelta
     2046@mfr_bind1
     2047[ @(λx.x)
     2048| cases(called) [#c_id | #c_ptr] normalize nodelta
     2049  [ @opt_to_res_preserve1 #bl #EQbl %{bl} % [2: %]
     2050    >(find_symbol_transf …
     2051          (λvars.transf_fundef … (λfn.(b_graph_translate … fn))) prog c_id)
     2052   assumption
     2053  | @mfr_bind1
     2054    [2: whd in match dpl_arg_retrieve; normalize nodelta @(ps_arg_retrieve_ok) |
     2055    | #bv1 @mfr_bind1
     2056      [2: whd in match dph_arg_retrieve; normalize nodelta @(ps_arg_retrieve_ok) |
     2057      | #bv2 @mfr_bind1
     2058        [ @(λx.x)
     2059        | whd in match pointer_of_bevals; normalize nodelta
     2060          cases bv1 normalize nodelta
     2061          [ | | #ptr1 #ptr2 #p | #by | #p | #ptr #p | #pc1 #p1]
     2062          try @res_preserve_error1
     2063          [ cases bv2 [ | | #ptr1' #ptr2' #p' | #by' | #p' | #ptr' #p' | #pc1' #p1']
     2064          normalize nodelta
     2065          [1,2,3,4,5: @res_preserve_error1
     2066          | @if_elim #_ [@mfr_return_eq1 % | @res_preserve_error1]
     2067          ]
     2068          ] whd in match sigma_beval; normalize nodelta cases(sigma_pc_opt ???)
     2069            normalize nodelta [2,4: #pc ] @res_preserve_error1
     2070        |
     2071        #ptr @if_elim #_ [@mfr_return_eq1 % | @res_preserve_error1]
     2072      ]
     2073    ]
     2074  ]
     2075 ]
     2076| #bl @opt_to_res_preserve1 whd in match code_block_of_block; normalize nodelta
     2077  @match_reg_elim [ #_ @opt_preserve_none1 | #prf @mfr_return_eq1 %]
     2078]
     2079qed.
     2080
     2081lemma bvpc_sigma_pc_to_sigma_beval : ∀prog : ertl_program.
     2082∀f_lbls,pc,p. sigma_pc_opt prog f_lbls pc ≠ None ? →
     2083BVpc (sigma_stored_pc prog f_lbls pc) p =
     2084sigma_beval prog f_lbls (BVpc pc p).
     2085#prog #f_lbls #pc #p #prf whd in match sigma_stored_pc;
     2086whd in match sigma_beval; normalize nodelta lapply prf
     2087cases(sigma_pc_opt ???) [ * #H @⊥ @H % | #pc' #_ % ]
     2088qed.
     2089
     2090lemma push_ra_ok : ∀prog : ertl_program.
     2091∀f_lbls,f_regs,restr,pc. sigma_pc_opt prog f_lbls pc ≠ None ? →
     2092    preserving1 ?? res_preserve1 …
     2093          (sigma_state prog f_lbls f_regs restr)
     2094          (sigma_state prog f_lbls f_regs restr)
     2095          (λst.push_ra ERTL_semantics st (sigma_stored_pc prog f_lbls pc))
     2096          (λst.push_ra ERTLptr_semantics st pc).
     2097#prog #f_lbls #f_regs #restr #pc #prf #st whd in match push_ra; normalize nodelta
     2098@mfr_bind1
     2099[  @(sigma_state prog f_lbls f_regs restr)
     2100|  >(bvpc_sigma_pc_to_sigma_beval … prf) @push_ok
     2101|  #st' >(bvpc_sigma_pc_to_sigma_beval … prf) @push_ok
     2102] qed.
     2103
     2104lemma ertl_save_frame_ok : ∀prog : ertl_program.
     2105∀f_lbls.∀f_regs : regs_funct.∀kind,restr.
     2106preserving1 ?? res_preserve1 ????
     2107           (λst. match fetch_internal_function … (globalenv_noinit … prog)
     2108                       (pc_block (pc … st)) with
     2109                 [ OK y ⇒ let 〈f,fn〉 ≝ y in
     2110                          let added ≝ added_registers … (prog_var_names … prog) fn
     2111                                       (f_regs (pc_block (pc … st))) in
     2112                          mk_state_pc ? (sigma_state prog f_lbls f_regs added st)
     2113                                        (sigma_stored_pc prog f_lbls (pc … st))
     2114                                        (sigma_stored_pc prog f_lbls (last_pop … st))
     2115                 | Error e ⇒ dummy_state_pc
     2116                 ])
     2117           (sigma_state prog f_lbls f_regs restr)
     2118           (ertl_save_frame kind it)
     2119           (match kind with
     2120            [ID ⇒ ertlptr_save_frame ID it
     2121            |PTR ⇒ λst. !st' ← push_ra … st (pc … st);
     2122                        ertlptr_save_frame ID it (set_no_pc … st' st)
     2123            ]).
     2124            xxxxxxxxxxxxxxxxxxx
     2125#prog #f_lbls #f_regs #kind #restr #st whd in match ertl_save_frame;
     2126whd in match ertlptr_save_frame; normalize nodelta @mfr_bind1
     2127[2: cases(fetch_internal_function ???) normalize nodelta
     2128    [ * #id #fn normalize nodelta
     2129   
     2130    change with (st_no_pc … st) in ⊢ (???????(??(?????%)?)(??%?));
     2131      @push_ra_ok
     2132
     2133lemma eval_call_ok   :
     2134 ∀prog : ertl_program.
     2135 let trans_prog ≝ ertl_to_ertlptr prog in
     2136∀ f_lbls,f_regs,stack_sizes.
     2137 ∀f_bl_r.
     2138 ∀ good :b_graph_transform_program_props ERTL_semantics ERTLptr_semantics
     2139     translate_data prog f_bl_r f_lbls f_regs.
     2140 ∀st2,st1',f,fn,called,args,dest,nxt.
     2141 let st1 ≝ sigma_state_pc prog f_lbls f_regs st2 in
     2142  fetch_statement ERTL_semantics …
     2143    (globalenv_noinit ? prog) (pc … st1) =
     2144      return 〈f, fn,
     2145        sequential … (CALL ERTL … called args dest ) nxt〉 →
     2146   eval_state … (ev_genv … (mk_prog_params ERTL_semantics prog stack_sizes)) st1 =
     2147    return st1' →
     2148∃is_call,st2_pre_call,is_call'.
     2149as_call_ident (ERTLptr_status trans_prog stack_sizes)
     2150 («st2_pre_call,is_call'») = as_call_ident (ERTL_status prog stack_sizes)
     2151  («st1, is_call») ∧
     2152(pc … st1) = sigma_stored_pc prog f_lbls (pc … st2_pre_call) ∧
     2153∃taa2 : trace_any_any (ERTLptr_status trans_prog stack_sizes) st2 st2_pre_call.
     2154∃ st2'. st1' = sigma_state_pc prog f_lbls f_regs st2' ∧
     2155eval_state ERTLptr_semantics …
     2156 (ev_genv … (mk_prog_params ERTLptr_semantics trans_prog stack_sizes)) st2_pre_call
     2157 =return st2'.
     2158#prog #f_lbls #f_regs #stack_size #f_bl_r #good #st2 #st1' #f #fn * [#c_id | #c_ptr]
     2159#args #dest #nxt #EQfetch lapply EQfetch >(fetch_stmt_ok_sigma_pc_ok … EQfetch)
     2160#EQfetch' lapply(fetch_statement_inv … EQfetch') * #EQfn normalize nodelta #EQstmt
     2161cases(b_graph_transform_program_fetch_internal_function … good … EQfn)
     2162#init_data * #calling' ** #EQcalling' whd in ⊢ (% → ?); cases(f_bl_r ?)
     2163[2,4: #x #y *] normalize nodelta #EQ destruct(EQ) * #_ #_ #_ #_ #pp_labs
     2164#_ #fresh_labs #fresh_regs #_ #_ #H cases(H … EQstmt) -H #labels * #registers
     2165** #EQlabels #EQregisters normalize nodelta >if_merge_right [2,4: %]
     2166whd in match translate_step;
     2167normalize nodelta whd in ⊢ (% → ?); * #bl * whd in ⊢ (% → ?);
     2168cases registers in EQregisters; -registers normalize nodelta
     2169[2,3: [ #x #y] #_ *|4: #r #tl] #EQregisters
     2170[ whd in ⊢ (% → ?); cases tl in EQregisters; -tl [2: #x #y #_ *] normalize nodelta
     2171#EQregisters] #EQ destruct(EQ) whd in ⊢ (% → ?); *
     2172#pre_l * #mid1 * #mid2 * #post_l *** #EQmid1 whd in ⊢ (% → ?);
     2173[ * #mid * #resg ** #EQ destruct(EQ) whd in ⊢ (% → ?);
     2174  * #nxt1 * #EQlow change with nxt1 in ⊢ (??%? → ?); #EQ destruct(EQ)
     2175  whd in ⊢ (% → ?); * #mid3 * #rest1 ** #EQ destruct(EQ) * #nxt1 *
     2176  #EQpush1 change with nxt1 in ⊢ (??%? → ?); #EQ destruct(EQ)
     2177  whd in ⊢ (% → ?); * #mid4 * #rest2 ** #EQ destruct(EQ) * #nxt1 * #EQhigh
     2178  change with nxt1 in ⊢ (??%? → ?); #EQ destruct(EQ) whd in ⊢ (% → ?);
     2179  * #mid5 * #rest3 ** #EQ destruct(EQ) * #nxt1 * #EQpush2
     2180  change with nxt1 in ⊢ (??%? → ?); #EQ destruct(EQ) whd in ⊢ (% → ?);
     2181] * #EQ1 #EQ2 destruct(EQ1 EQ2) whd in EQmid1 : (??%%); destruct(EQmid1)
     2182whd in ⊢ (% → ?); * #nxt1 * #EQcall #EQ destruct(EQ) whd in ⊢ (% → ?);
     2183* #EQ destruct(EQ) change with nxt1 in ⊢ (??%? → ?); #EQ destruct(EQ)
     2184 whd in match eval_state; normalize nodelta >EQfetch
     2185>m_return_bind whd in match eval_statement_no_pc; normalize nodelta >m_return_bind
     2186whd in match eval_statement_advance; whd in match eval_call; normalize nodelta
     2187>(fetch_stmt_ok_sigma_state_ok … EQfetch) >(fetch_stmt_ok_sigma_pc_ok … EQfetch)
     2188>(fetch_stmt_ok_sigma_last_pop_ok … EQfetch) #H @('bind_inversion H) -H
     2189#c_bl whd in match set_no_pc; normalize nodelta #H lapply(err_eq_from_io ????? H) -H
     2190#EQc_bl cases(block_of_call_ok ??????? EQc_bl) #c_bl' * #EQc_bl' #EQ destruct(EQ)
     2191#H @('bind_inversion H) -H * #f1 * [1,3: #fn1 |*: #ext_f] #EQfn1 normalize nodelta
     2192[3,4: #H @('bind_inversion H) -H #st whd in match eval_external_call; normalize nodelta
     2193      #H @('bind_inversion H) -H #list_val #_ #H @('bind_inversion H) -H #x
     2194      #_ #H @('bind_inversion H) -H #y whd in match do_io; normalize nodelta
     2195      whd in ⊢ (???% → ?); #ABS destruct(ABS) ] #H lapply(err_eq_from_io ????? H) -H
     2196#H @('bind_inversion H) -H #st1'' >(fetch_stmt_ok_sigma_pc_ok … EQfetch)
     2197>(fetch_stmt_ok_sigma_last_pop_ok … EQfetch) whd in match kind_of_call;
     2198normalize nodelta change with (ertl_save_frame ? it ?) in ⊢ (??%? → ?);
     2199[2: @PTR |4: @ID] #EQst1'' #H @('bind_inversion H) -H #st1'''
     2200whd in match eval_internal_call; normalize nodelta #H @('bind_inversion H) -H
     2201#s_size #H lapply(opt_eq_from_res ???? H) -H
     2202change with (stack_size ?) in ⊢ (??%? → ?); #EQs_size whd in ⊢ (??%? → ?);
     2203whd in ⊢ (???% → ?); #EQ destruct(EQ) whd in ⊢ (??%% → ?); #EQ destruct(EQ) %
     2204[1,3: @hide_prf whd in ⊢ (??%?); >EQfetch %]
     2205[ letin pairpc ≝ (beval_pair_of_pc (pc_of_point ERTLptr_semantics (pc_block (pc … st2)) mid1))
     2206  letin st2_pre ≝ (mk_state_pc ?
     2207    (mk_state ? (st_frms … st2) (both_is (\fst pairpc) (\snd pairpc))
     2208    (carry … st2) (〈add ?? (\fst (regs … st2)) r (\snd pairpc),\snd(regs … st2)〉)
     2209    (m … st2))
     2210    (pc_of_point ERTLptr_semantics (pc_block (pc … st2)) mid1)
     2211    (last_pop … st2))
     2212 %{st2_pre}
     2213| %{st2}
     2214] % 
     2215[1,3: @hide_prf whd in ⊢ (??%?); whd in match fetch_statement; normalize nodelta
     2216      >EQcalling' >m_return_bind [>point_of_pc_of_point ] >EQcall >m_return_bind % ]
     2217%
     2218[1,3: %
     2219  [1,3: whd in ⊢ (??%%); whd in match fetch_statement in ⊢ (??%?);
     2220        normalize nodelta >EQcalling' in ⊢ (??(match % with [_ ⇒ ? | _ ⇒ ?])?);
     2221        >m_return_bind in ⊢ (??(match % with [_ ⇒ ? | _ ⇒ ?])?);
     2222       [ >point_of_pc_of_point in ⊢ (??(match % with [_ ⇒ ? | _ ⇒ ?])?);]
     2223       >EQcall in ⊢ (??(match % with [_ ⇒ ? | _ ⇒ ?])?); normalize nodelta
     2224       >(fetch_stmt_ok_sigma_pc_ok … EQfetch) in ⊢ (???(match % with [_ ⇒ ? | _ ⇒ ?]));
     2225       >EQfetch' in ⊢ (???(match % with [_ ⇒ ? | _ ⇒ ?])); %
     2226  |*: whd in match sigma_stored_pc; whd in match sigma_pc_opt; normalize nodelta
     2227      @if_elim change with (pc_block(pc … st2)) in match (pc_block ?);
     2228      [1,3: @eqZb_elim [2,4: #_ *] #EQbl #_
     2229      >fetch_internal_function_no_minus_one in EQcalling'; [2,4: assumption]
     2230      whd in ⊢ (???% → ?); #ABS destruct(ABS) ] #_
     2231      [ >point_of_pc_of_point >(get_sigma_last … good … EQfn EQstmt EQlabels)
     2232      | >(get_sigma_idempotent … good … EQfn EQstmt EQlabels)
     2233      ]
     2234      >m_return_bind >pc_of_point_of_pc %
     2235  ]
     2236|4: %{(taa_base …)}
     2237|2: letin st2'' ≝ (mk_state_pc ?
     2238                   (mk_state ? (st_frms … st2) (empty_is) (carry … st2)
     2239                      (〈add ?? (\fst (regs … st2)) r (\fst pairpc),\snd(regs … st2)〉)
     2240                      (m … st2)) (pc_of_point ERTLptr_semantics (pc_block (pc … st2)) mid)
     2241                      (last_pop … st2))
     2242    letin st2''' ≝ (mk_state_pc ? (set_istack ? (one_is (\fst pairpc)) st2'')
     2243                    (pc_of_point ERTLptr_semantics (pc_block (pc … st2)) mid3)
     2244                    (last_pop … st2))
     2245    letin st2''''≝ (mk_state_pc ? (mk_state ? (st_frms … st2) (istack … st2''')
     2246    (carry … st2)
     2247    (〈add ?? (\fst (regs … st2''')) r (\snd pairpc),\snd (regs … st2)〉) (m … st2'''))
     2248    (pc_of_point ERTLptr_semantics (pc_block (pc … st2)) mid4) (last_pop … st2))
     2249    %{(taa_step ? st2 st2'' st2_pre ???
     2250        (taa_step ? st2'' st2''' st2_pre ???
     2251           (taa_step ? st2''' st2'''' st2_pre ???
     2252              (taa_step ? st2'''' st2_pre st2_pre ??? (taa_base …)))))}
     2253   [3,6,7,10: % whd in ⊢ (% → ?); * #H @H whd in ⊢ (??%?);
     2254              whd in match fetch_statement; normalize nodelta >EQcalling' >m_return_bind
     2255              [ >point_of_pc_of_point >EQhigh
     2256              | >point_of_pc_of_point >EQcall
     2257              | >point_of_pc_of_point >EQpush2
     2258              | >point_of_pc_of_point >EQpush1 ] %
     2259   |1,2,4,5,8,9,11,12: whd
     2260       [1,3,6,8: whd in match eval_state; normalize nodelta
     2261       |*: whd in ⊢ (??%?);
     2262       ]
     2263       whd in match fetch_statement; normalize nodelta >EQcalling' >m_return_bind
     2264       [1,5: >point_of_pc_of_point >EQpush1 >m_return_bind [2: %]
     2265       |2,6: >point_of_pc_of_point >EQpush2 >m_return_bind [2: %]
     2266       |3,7: >point_of_pc_of_point >EQhigh >m_return_bind [2: %]
     2267       |*: >EQlow >m_return_bind [2: %]
     2268       ]
     2269       whd in match eval_statement_no_pc; whd in match eval_seq_no_pc; normalize nodelta
     2270       whd in match (eval_ext_seq ?????????); whd in match (get_pc_from_label ?????);
     2271       whd in match block_of_funct_id; normalize nodelta
     2272       [1,2: whd in match acca_arg_retrieve; normalize nodelta
     2273             change with (ps_reg_retrieve ??) in match (acca_arg_retrieve_ ?????);
     2274             whd in match ps_reg_retrieve; whd in match reg_retrieve; normalize nodelta
     2275             >lookup_add_hit >m_return_bind [%| >add_idempotent %]
     2276       |*: @('bind_inversion EQfn) * #f2 * #fn2 whd in match fetch_function;
     2277           normalize nodelta #H lapply(opt_eq_from_res ???? H) -H
     2278           #H @('bind_inversion H) -H #f3 #EQf3 #H @('bind_inversion H) -H
     2279           #fn4 #_ whd in ⊢ (??%%→ ??%% → ?); #EQ1 #EQ2 destruct(EQ1 EQ2)
     2280          >(find_symbol_transf …
     2281             (λvars.transf_fundef … (λfn.(b_graph_translate … fn))) prog f)
     2282          >(symbol_of_block_rev … EQf3) >m_return_bind >code_block_of_block_eq
     2283          normalize nodelta >(pc_of_label_eq … EQcalling') normalize nodelta
     2284          whd in match ps_reg_store_status; normalize nodelta >m_return_bind [%]
     2285          whd in match eval_statement_advance; normalize nodelta whd in match set_no_pc;
     2286          normalize nodelta whd in match next; whd in match set_pc; normalize nodelta
     2287          @eq_f @eq_f3 [2,3: %] whd in match set_regs; normalize nodelta
     2288          cut(istack … st2 = empty_is)
     2289          [ @('bind_inversion EQst1'') #new_st whd in match push_ra; normalize nodelta
     2290            #H @('bind_inversion H) -H #new_st' whd in match push; normalize nodelta
     2291            #H @('bind_inversion H) -H #new_is whd in match sigma_state; normalize nodelta
     2292            cases(istack ? st2) [ #_ #_ #_ #_ % |3: #bv1 #bv2 whd in ⊢ (??%% → ?); #EQ destruct]
     2293            #bv1 whd in ⊢ (??%% → ?); #EQ destruct(EQ) whd in match set_istack; normalize nodelta
     2294            whd in ⊢ (??%% → ?); #EQ destruct #H @('bind_inversion H) -H #new_is2 whd in ⊢ (??%% → ?);
     2295            #EQ destruct(EQ) ] #EQ >EQ %
     2296       ]
     2297   ]
     2298]
     2299cases(b_graph_transform_program_fetch_internal_function … good c_bl' f1 fn1 ?)
     2300[2,4: whd in match fetch_internal_function; normalize nodelta lapply(err_eq_from_io ????? EQfn1)
     2301      -EQfn1 #EQfn1 >EQfn1 %]
     2302#init * #t_fn1 ** #EQt_fn1 #_ * #_ #_ #_ #EQentry #_ #_ #_ #_ #_ #_ #_
     2303[2: %{(mk_state_pc ? (set_frms ERTL_state (〈\fst (regs … st2_pre),pc_block(pc … st2)〉 :: (st_frms … st2))
     2304                                 (set_regs ERTL_state (〈empty_map …,\snd (regs … st2)〉) st2_pre))
     2305                     (pc_of_point (mk_prog_params ERTLptr_semantics (ertl_to_ertlptr prog) stack_size)
     2306                         c_bl' (joint_if_entry … t_fn1))
     2307                     (last_pop … st2))}
     2308| @('bind_inversion EQst1'') #new_st
     2309  cut(pc … st2 = sigma_stored_pc prog f_lbls (pc … st2))
     2310  [ whd in match sigma_stored_pc; whd in match sigma_pc_opt; normalize nodelta
     2311    @if_elim [ @eqZb_elim [2: #_ *] #EQbl >fetch_internal_function_no_minus_one in EQfn; [2: //] #EQ destruct]
     2312    #_ >(get_sigma_idempotent … good … EQfn EQstmt EQlabels) >m_return_bind >pc_of_point_of_pc %]
     2313 #EQ >EQ #EQnew_st cases(push_ra_ok … EQnew_st)
     2314 [2: lapply EQ whd in match sigma_stored_pc; normalize nodelta cases(sigma_pc_opt ???) [2: #x #_ % #EQ destruct]
     2315     normalize  nodelta #ABS >fetch_internal_function_no_zero in EQfn; [2: >ABS %] #EQ destruct]
     2316 #t_new_st * #EQt_new_st #new_st_t_new_st whd in ⊢ (???% → ?); #EQ destruct(EQ)
     2317 %{(mk_state_pc ? (set_frms ERTL_state (〈(\fst (regs … t_new_st)), pc_block (pc … st2)〉 :: (st_frms … st2))
     2318                             (set_regs ERTL_state (〈empty_map …,\snd(regs … st2)〉) t_new_st))
     2319                   (pc_of_point (mk_prog_params ERTLptr_semantics (ertl_to_ertlptr prog) stack_size)
     2320                         c_bl' (joint_if_entry … t_fn1))
     2321                   (last_pop … st2))}
     2322] %
     2323[1,3: whd in match sigma_state_pc; normalize nodelta whd in match fetch_internal_function;
     2324      normalize nodelta lapply(err_eq_from_io ????? EQfn1) -EQfn1 #EQfn1 >EQfn1 >m_return_bind
     2325      normalize nodelta @eq_f3 try % [2,4: >EQentry %] whd in match sigma_state; normalize nodelta
     2326      whd in match set_frms; whd in match set_regs; normalize nodelta
     2327      [ @('bind_inversion EQst1'') #new_st #H @('bind_inversion H) -H #new_st1
     2328        #H @('bind_inversion H) -H #new_is whd in match is_push; normalize nodelta
     2329        whd in match sigma_state; normalize nodelta cases (istack … st2) normalize nodelta
     2330        [3: #bv1 #bv2 whd in ⊢ (???% → ?); #EQ destruct(EQ) |2: #bv] whd in ⊢ (??%% → ?);
     2331        #EQ destruct(EQ) whd in ⊢ (??%% → ?); #EQ destruct(EQ) whd in ⊢ (??%% → ?); #EQ destruct
     2332        whd in ⊢ (???% → ?); #EQ destruct(EQ)
     2333      ]
     2334      cut(∀ a1,a2,b1,b2,c1,c2,d1,d2,e1,e2.a1=a2 → b1 = b2 → c1 = c2 → d1 = d2 → e1 = e2 →
     2335            mk_state ERTL_semantics a1 b1 c1 d1 e1 =
     2336            mk_state ERTL_semantics a2 b2 c2 d2 e2)
     2337       [1,3: #H1 #H2 #H3 #H4 #H5 #H6 #H7 #H8 #H9 #H10 #H11 #H12 #H13 #H14 #H15 //]
     2338       #APP @APP
     2339       [ whd in match sigma_frames in ⊢ (???%); normalize nodelta whd in match sigma_frames_opt;
     2340         whd in match m_list_map; normalize nodelta whd in match (foldr ?????);
     2341         normalize nodelta >EQfn >m_return_bind normalize nodelta
     2342         check coerced_step_list_in_code
     2343         whd in match sigma_frames; whd in match sigma_frames_opt; whd in match m_list_map;
     2344         normalize nodelta cases(foldr ? (Option ?) ???) [%
     2345        //
     2346        whd in ⊢
     2347      xxxxxxxxxxxxxxxxxxxxxxxx
     2348     
     2349      change with c_bl' in match (pc_block ?) in ⊢ (???%); >EQfn1               
     2350change with (ge … (ev_genv (mk_prog_params ERTL_semantics prog stack_size)))
     2351 in match (globalenv_noinit ? prog); >EQfn1
     2352change with 
     2353 
     2354          #EQnew_st whd in ⊢ (???% → ?); #EQ destruct(EQ) cases(push_ra_ok ???????? EQnew_st)
     2355         
     2356          xxxxxxxxxxx
     2357          lapply EQfn whd in match fetch_internal_function; whd in match fetch_function;
     2358          normalize nodelta
     2359          check find_symbol
     2360letin (*〈addrl,addrh〉*) x ≝  beval_pair_of_pc ? %
     2361
     2362
     2363
     2364%{(mk_state_pc ?
     2365    (mk_state ? (st_frms … st2)
     2366    (both_is (\snd (beval_pair_of_pc (pc … st2)))
     2367             (\fst (beval_pair_of_pc (pc … st2))))
     2368    (carry … st2) (regs … st2) (m … st2))
     2369    (pc … st2)
     2370    (last_pop … st2))}
     2371
     2372
     2373
    18622374
    18632375inductive ex_Type1 (A:Type[1]) (P:A → Prop) : Prop ≝
     
    18652377(*interpretation "exists in Type[1]" 'exists x = (ex_Type1 ? x).*)
    18662378
    1867 include "joint/semantics_blocks.ma".
    1868 
    1869 lemma fetch_internal_function_no_zero :
    1870 ∀F,V,i,p,bl.
    1871   block_id (pi1 … bl) = 0 →
    1872   fetch_internal_function ?
    1873  
    1874   (globalenv (λvars.fundef (F vars)) V i p) bl =
    1875   Error ? [MSG BadFunction].
    1876 #F #V #i #p #bl #EQbl whd in match fetch_internal_function;
    1877 normalize nodelta >fetch_function_no_zero [2: assumption] %
    1878 qed.
    1879 
    1880 lemma fetch_internal_function_no_minus_one :
    1881 ∀F,V,i,p,bl.
    1882   block_id (pi1 … bl) = -1 →
    1883   fetch_internal_function ?
    1884  
    1885   (globalenv (λvars.fundef (F vars)) V i p) bl =
    1886   Error ? [MSG BadFunction].
    1887 #F #V #i #p #bl #EQbl whd in match fetch_internal_function;
    1888 normalize nodelta >fetch_function_no_minus_one [2: assumption] %
    1889 qed.
    1890 
    1891 lemma fetch_statement_no_zero :
    1892 ∀pars,prog,stack_size,pc.
    1893 block_id(pi1 … (pc_block pc)) = 0 →
    1894 fetch_statement pars (prog_var_names … prog)
    1895 (ev_genv (mk_prog_params pars prog stack_size)) pc =
    1896 Error ? [MSG BadFunction].
    1897 #pars #vars #ge #pc #EQpc whd in match fetch_statement; normalize nodelta
    1898 >fetch_internal_function_no_zero [2: assumption] %
    1899 qed.
    1900 
    1901 lemma fetch_statement_no_minus_one :
    1902 ∀pars,prog,stack_size,pc.
    1903 block_id(pi1 … (pc_block pc)) = -1 →
    1904 fetch_statement pars (prog_var_names … prog)
    1905 (ev_genv (mk_prog_params pars prog stack_size)) pc =
    1906 Error ? [MSG BadFunction].
    1907 #pars #vars #ge #pc #EQpc whd in match fetch_statement; normalize nodelta
    1908 >fetch_internal_function_no_minus_one [2: assumption] %
    1909 qed.
    1910 
    1911 
    1912 
     2379lemma ertl_to_ertlptr_ok:
     2380∀prog.
     2381let trans_prog ≝ ertl_to_ertlptr prog in
     2382∀ f_lbls,f_regs,stack_sizes.
     2383 ∀f_bl_r.
     2384 b_graph_transform_program_props ERTL_semantics ERTLptr_semantics
     2385     translate_data prog f_bl_r f_lbls f_regs →
     2386   ex_Type1 … (λR.
     2387   status_simulation
     2388    (ERTL_status prog stack_sizes) (ERTLptr_status trans_prog stack_sizes) R).
     2389#prog #f_lbls #f_regs #stack_size #f_bl_r #good %
     2390[@ERTLptrStatusSimulation assumption]
     2391whd in match status_simulation; normalize nodelta
     2392whd in match ERTL_status; whd in match ERTLptr_status; normalize nodelta
     2393whd in ⊢ (% → % → % → % → ?); #st1 #st1' #st2
     2394change with
     2395  (eval_state ERTL_semantics (prog_var_names ???) ?? = ? → ?) 
     2396#EQeval @('bind_inversion EQeval)
     2397** #id #fn #stmt #H lapply (err_eq_from_io ????? H) -H #EQfetch
     2398#_  whd in match ERTLptrStatusSimulation; normalize nodelta #EQst2 destruct
     2399cases stmt in EQfetch; -stmt
     2400[ * [ #cost | #called_id #args #dest| #reg #lbl | #seq] #nxt | #fin_step | *]
     2401#EQfetch
     2402change with (joint_classify ??) in ⊢ (match % with [ _ ⇒ ? | _ ⇒ ? ]);
     2403[ (*COST*) whd in match joint_classify; normalize nodelta >EQfetch >m_return_bind
     2404  normalize nodelta
     2405  cases(eval_cost_ok … good … EQfetch EQeval) #st2' * #EQst2' * #taf #tafne
     2406  %{st2'} %{taf} >tafne normalize nodelta % [ % [@I | assumption]]
     2407  whd >EQst2' >(as_label_ok … good … st2') [%] cases daemon (* needs lemma see below!! *)
     2408| (*CALL*)  whd in match joint_classify; normalize nodelta >EQfetch >m_return_bind
     2409          normalize nodelta #is_call_st1
     2410          cases(eval_call_ok … good … EQfetch EQeval) #is_call_st1'
     2411          * #st2_pre_call * #is_call_st2_pre_call * * #Hcall
     2412          #call_rel * #taa * #st2' * #sem_rel #eval_rel
     2413          %{(«st2_pre_call,is_call_st2_pre_call»)} % [ % assumption]
     2414          %{st2'} %{st2'} %{taa} %{(taa_base …)} % [ % assumption]
     2415          whd >sem_rel >(as_label_ok … good … st2') [%] cases daemon (*TODO*)
     2416| (*COND*) whd in match joint_classify; normalize nodelta >EQfetch >m_return_bind
     2417          normalize nodelta #n_costed
     2418          cases(eval_cond_ok … good … EQfetch EQeval) [2: @n_costed]
     2419          #st2' * #EQst2' * #taf #tafne %{st2'} %{taf} >tafne % [% [@I|assumption]]
     2420          whd >EQst2' >(as_label_ok … good … st2') [%] cases daemon (*TODO*)
     2421| (*seq*) whd in match joint_classify; normalize nodelta >EQfetch >m_return_bind
     2422          normalize nodelta
     2423          cases (eval_seq_no_call_ok … good … EQfetch EQeval)
     2424          #st3 * #EQ destruct *  #taf #taf_spec %{st3} %{taf} 
     2425          % [% //] whd >(as_label_ok … good … st3) [%]
     2426          cases daemon (*needs lemma about preservation of fetch_statement *)
     2427|  cases fin_step in EQfetch;
     2428  [ (*GOTO*) #lbl #EQfetch  whd in match joint_classify; normalize nodelta
     2429     >EQfetch in ⊢ (match % with [ _ ⇒ ? | _ ⇒ ? ]); normalize nodelta
     2430    cases (eval_goto_ok … good  … EQfetch EQeval)
     2431    #st3 * #EQ destruct * #taf #tarne %{st3} %{taf} >tarne normalize nodelta
     2432    % [% //] whd >(as_label_ok … good … st3) [%]
     2433    cases daemon (*needs lemma about preservation of fetch_statement *)
     2434  | (*RETURN*) #EQfetch
     2435     whd in match joint_classify; normalize nodelta
     2436    >EQfetch in ⊢ (match % with [ _ ⇒ ? | _ ⇒ ? ]); normalize nodelta
     2437    cases (eval_return_ok … good … EQfetch EQeval) #is_ret
     2438    * #st3 * #EQ destruct * #after_ret * #taf ** #taf_prf #EQeval' #ret_prf
     2439    % [2: % [2: % [2: %{(taa_base …)} %{taf}] |*: ] |*:]
     2440    % [2: whd >(as_label_ok … good … st3) [%] cases daemon (*needs lemma *)]
     2441    % [2: assumption] % [2: %] % [2: assumption] % assumption
     2442  | (*TAILCALL*) *
     2443  ]
     2444]
     2445qed.
     2446
     2447(*
    19132448lemma foo :
    19142449 ∀P1_unser,P2_unser: unserialized_params.
     
    20622597#taaf #Htaaf %{st''}
    20632598 % [%] cases daemon
    2064  qed.
    2065 
    2066 lemma lookup_opt_none_transf :
    2067 ∀prog : ertl_program.
    2068 let trans_prog ≝ ertl_to_ertlptr prog in
    2069 ∀x.lookup_opt
    2070     (fundef
    2071      (joint_closed_internal_function ERTL
    2072       (prog_var_names (joint_function ERTL) ℕ prog))) x
    2073      (functions
    2074        (fundef
    2075         (joint_closed_internal_function ERTL
    2076          (prog_var_names (joint_function ERTL) ℕ prog)))
    2077        (globalenv_noinit (joint_function ERTL) prog)) =None ? →
    2078 lookup_opt
    2079     (fundef
    2080      (joint_closed_internal_function ERTLptr
    2081       (prog_var_names (joint_function ERTLptr) ℕ trans_prog))) x
    2082      (functions
    2083        (fundef
    2084         (joint_closed_internal_function ERTLptr
    2085          (prog_var_names (joint_function ERTLptr) ℕ trans_prog)))
    2086        (globalenv_noinit (joint_function ERTLptr) trans_prog)) =None ?.
    2087 #prog #x #EQlookup
    2088 whd in match ertl_to_ertlptr in ⊢ (??(???(??%))?); whd in match transform_program;
    2089 whd in match transf_program; normalize nodelta whd in match globalenv_noinit;
    2090 whd in match globalenv; whd in match globalenv_allocmem;
    2091 whd in match add_globals; normalize nodelta
    2092 cases daemon
    2093 qed.
    2094 
    2095  
    2096  
    2097 lemma fetch_function_none :
    2098 ∀prog : ertl_program.
    2099 let trans_prog ≝ ertl_to_ertlptr prog in
    2100 ∀bl.
    2101 fetch_function
    2102         (fundef
    2103          (joint_closed_internal_function ERTL
    2104           (prog_var_names (joint_function ERTL) ℕ prog)))
    2105         (globalenv_noinit (joint_function ERTL) prog) bl = Error ? [MSG BadFunction] →
    2106 fetch_function
    2107         (fundef
    2108          (joint_closed_internal_function ERTLptr
    2109           (prog_var_names (joint_function ERTLptr) ℕ trans_prog)))
    2110         (globalenv_noinit (joint_function ERTLptr) trans_prog) bl = Error ? [MSG BadFunction].
    2111 #prog #bl whd in match fetch_function in ⊢ (% → ?); normalize nodelta
    2112 <(symbol_for_block_transf … (λn:ℕ.[Init_space n]) prog …
    2113                          (λvars.transf_fundef … (translate_internal …)) bl)
    2114 change with (symbol_for_block
    2115               (fundef
    2116                 (joint_closed_internal_function ERTLptr
    2117                   (prog_var_names (joint_function ERTLptr) ℕ (ertl_to_ertlptr prog))))
    2118                (globalenv_noinit (joint_function ERTLptr) (ertl_to_ertlptr prog)) bl)
    2119                in match (symbol_for_block ???);
    2120 whd in match fetch_function; normalize nodelta cases(symbol_for_block ???) [#_ %]
    2121 #id >m_return_bind inversion(find_funct_ptr ???)
    2122 [2: #x #_ whd in ⊢ (??%% → ?); #EQ destruct] whd in match find_funct_ptr;
    2123 normalize nodelta cases(block_region bl) normalize nodelta [ #_ #_ >m_return_bind %]
    2124 cases(block_id bl) normalize nodelta [1,2: [2: #x] #_ #_ >m_return_bind %]
    2125 #x whd in match globalenv_noinit; whd in match globalenv; normalize nodelta
    2126 whd in match globalenv_allocmem; normalize nodelta #EQlookup
    2127 >(lookup_opt_none_transf … EQlookup) #_ %
    2128 qed.
    2129 
    2130 lemma fetch_function_err :
    2131 ∀F,ge,bl,e. fetch_function F ge bl = Error ? e → e = [MSG BadFunction].
    2132 #F #ge #bl #e whd in match fetch_function; normalize nodelta
    2133 cases(symbol_for_block ???) [ normalize #EQ destruct %]
    2134 #id >m_return_bind cases(find_funct_ptr ???) normalize [2: #x]
    2135 #EQ destruct %
    2136 qed.
    2137 
    2138  
    2139 lemma fetch_internal_function_none :
    2140 ∀ prog : ertl_program.
    2141 let trans_prog ≝ ertl_to_ertlptr prog in
    2142 ∀bl.
    2143 fetch_internal_function
    2144    (joint_closed_internal_function ERTL
    2145     (prog_var_names (joint_function ERTL) ℕ prog))
    2146    (globalenv_noinit (joint_function ERTL) prog) bl = Error ? [MSG BadFunction] →
    2147 fetch_internal_function
    2148    (joint_closed_internal_function ERTLptr
    2149     (prog_var_names (joint_function ERTLptr) ℕ trans_prog))
    2150    (globalenv_noinit (joint_function ERTLptr) trans_prog) bl = Error ? [MSG BadFunction].
    2151 #prog #bl whd in match fetch_internal_function; normalize nodelta
    2152 inversion(fetch_function ???)
    2153 [2: #err_msg #EQfetch lapply(fetch_function_err … EQfetch) #EQ destruct #_
    2154     >(fetch_function_none … EQfetch) %] * #f * #fn #EQfetch >m_return_bind
    2155 normalize nodelta whd in ⊢ (??%? → ?); #EQ destruct
    2156 >(fetch_function_transf … (λvars.transf_fundef … (translate_internal …)) … EQfetch)
    2157 >m_return_bind %
    2158 qed.
    2159  
    2160 lemma fetch_internal_function_err :
    2161 ∀F,ge,bl,e. fetch_internal_function F ge bl = Error ? e → e = [MSG BadFunction].
    2162 #F #ge #bl #e whd in match fetch_internal_function; normalize nodelta
    2163 inversion(fetch_function ???)
    2164 [2: #e #EQf lapply(fetch_function_err … EQf) #EQ destruct whd in ⊢ (??%? → ?);
    2165     #EQ destruct %] * #id * #fn #EQf >m_return_bind normalize nodelta
    2166 whd in ⊢ (??%? → ?); #EQ destruct %
    2167 qed.
    2168 
    2169  
    2170    
    2171  
    2172 lemma as_label_ok : ∀ prog : ertl_program.
    2173 let trans_prog ≝ ertl_to_ertlptr prog in
    2174 ∀ good,stack_sizes,st.
    2175 as_label (ERTLptr_status trans_prog stack_sizes) st = as_label
    2176 (ERTL_status prog stack_sizes) (sigma_state_pc prog good st).
    2177 #prog #good #stack_size #st whd in match as_label; normalize nodelta
    2178 whd in match (as_pc_of ? ?); whd in match (as_pc_of ? ?);
    2179 whd in match sigma_state_pc; normalize nodelta @if_elim
    2180 [ @eqZb_elim [2: #_ *] #EQbl * whd in match (as_label_of_pc ??);
    2181   >fetch_statement_no_minus_one [2: assumption] normalize nodelta
    2182   whd in match (as_label_of_pc ??); >fetch_statement_no_zero [2: %] %]
    2183 #_ inversion(fetch_internal_function ???)
    2184 [2: #e #EQf lapply(fetch_internal_function_err … EQf) #EQ destruct normalize nodelta
    2185     whd in match (as_label_of_pc ??); whd in match fetch_statement; normalize nodelta
    2186     >(fetch_internal_function_none … EQf) whd in ⊢ (??%%);
    2187     >fetch_statement_no_zero [2: %] % ] * #f #fn #EQf normalize nodelta
    2188 whd in match (as_label_of_pc ??) in ⊢ (???%); whd in match fetch_statement;
    2189 normalize nodelta >EQf >m_return_bind inversion(stmt_at ????) [cases daemon (*to discuss with Paolo*)]
    2190 * [ * [ * [ #id | #addr ] #args #dst | #acc_r #lbl | #seq ] #nxt | #fin | *]
    2191 #EQstmt_at >m_return_bind normalize nodelta
    2192 cases(multi_fetch_ok … (good fn) … EQstmt_at)
    2193 #labs * #regs ** #EQlabs #EQregs normalize nodelta whd in match translate_step;
    2194 normalize nodelta
    2195 [1,3,4: * #step_block * whd in match (bind_new_instantiates ?????);
    2196         cases regs in EQregs; [2,4,6: #r #tl #EQ normalize nodelta *]
    2197         #EQregs normalize nodelta #EQ destruct * #dst *
    2198         whd in match (step_list_in_code ???????); cases labs in EQlabs;
    2199         [2,4,6: #lb #tl #EQ normalize nodelta *] #EQlabs normalize nodelta
    2200         #EQ destruct * #nxt1 * #EQ_s_stmt #EQ destruct
    2201         whd in match (as_label_of_pc ??); whd in match fetch_statement;
    2202         normalize nodelta
    2203         >(fetch_internal_function_transf … (λvars.translate_internal …) … EQf)
    2204         >m_return_bind >EQ_s_stmt >m_return_bind normalize nodelta [1,2: %]
    2205         cases seq
    2206         [#str % | #c % | #H1 % | #H3 % | #x % | #H5 #H6 #H7 #H8 %
    2207         | #H10 #H11 #H12 #H13 #H14 % | #H16 #H17 #H18 % | #H20 #H21 #H22 #H23 %
    2208         | % | % | #H25 #H26 #H27 % | #H29 #H30 #H31 % | #H33 %]
    2209 | * #step_block whd in match (bind_new_instantiates ?????);
    2210   cases regs in EQregs; [ #EQ normalize nodelta **] #reg #tl #EQregs
    2211   normalize nodelta whd in match (bind_new_instantiates ?????);
    2212   cases tl in EQregs; [2: #reg1 #tl1 #EQ normalize nodelta **]
    2213   #EQreg normalize nodelta * #EQ destruct * #dst *
    2214   whd in match (step_list_in_code ???????); cases labs in EQlabs;
    2215   [ #_ normalize nodelta *] #lbl #tl #EQlabs normalize nodelta *
    2216   * #nxt1 * #EQ_s_stmt #_ #_ #_ whd in match (as_label_of_pc ??);
    2217   whd in match fetch_statement; normalize nodelta
    2218    >(fetch_internal_function_transf … (λvars.translate_internal …) … EQf)
    2219    >m_return_bind >EQ_s_stmt >m_return_bind normalize nodelta %
    2220 | (whd in match translate_fin_step; normalize nodelta) *
    2221   #fin_block * whd in match (bind_new_instantiates ?????); cases regs in EQregs;
    2222   [2: #r #tl #_ normalize nodelta *] #EQregs normalize nodelta #EQ destruct
    2223   * #list_l * #lbl ** #EQ destruct whd in match (step_list_in_code ???????);
    2224   normalize nodelta cases list_l in EQlabs; [2: #lbl1 #tl #_ normalize nodelta *]
    2225   #EQlabs normalize nodelta #EQ destruct whd in match fin_step_in_code;
    2226   normalize nodelta #EQ_s_stmt whd in match (as_label_of_pc ??);
    2227    whd in match fetch_statement; normalize nodelta
    2228    >(fetch_internal_function_transf … (λvars.translate_internal …) … EQf)
    2229    >m_return_bind >EQ_s_stmt >m_return_bind normalize nodelta %
    2230 ]
    2231 qed.
    2232 
    2233 (*
    2234 #H1 #H2 #H3 *
    2235 
    2236  ∀P1_unser,P2_unser: unserialized_params.
    2237  ∀P1_sem_unser,P2_sem_unser.
    2238  ∀init,translate_step.
    2239  ∀translate_fin_step.
    2240  ∀closed_graph_translate.
    2241  ∀prog.
    2242  ∀stack_size.
    2243  ∀sigma_state_pc.
    2244  (∀s. pc_block (pc … (sigma_state_pc s)) = pc_block … (pc … s)) →
    2245  ∀st : state_pc P2_sem.
    2246  ∀st' : state_pc P1_sem.
    2247  ∀f.
    2248  ∀fn: joint_closed_internal_function P1_sem (globals (mk_prog_params P1_sem prog stack_size)).
    2249  luniverse_ok … fn →
    2250  ∀stmt,nxt.
    2251  (∀pre_Instrs',last_Instrs',dst.
    2252    ∃st''.∃st'''.∃st''''.
    2253     repeat_eval_seq_no_pc (mk_prog_params P2_sem trans_prog stack_size)
    2254      f (translate_internal ? fn) (map_eval ?? pre_Instrs' dst) st = return st''' ∧
    2255     eval_seq_no_pc ? (prog_var_names … trans_prog) (ev_genv … (mk_prog_params P2_sem trans_prog stack_size))
    2256                       f (translate_internal … fn) (last_Instrs' dst) st''' = return st'''' ∧
    2257     st'' = (mk_state_pc (mk_prog_params P2_sem trans_prog stack_size)
    2258      st'''' (pc_of_point P2_sem (pc_block (pc … (sigma_state_pc st))) dst) (last_pop … st)) ∧
    2259     st' = sigma_state_pc st'' ∧
    2260     let P2_prog_params ≝ mk_prog_params P2_sem trans_prog stack_size in
    2261     let P2_globals ≝ globals P2_prog_params in
    2262      All
    2263       (joint_seq … P2_globals)
    2264       (no_cost_label … P2_globals)
    2265       (map_eval (code_point P2_sem) (joint_seq … P2_globals) pre_Instrs' dst)) →
    2266 
    2267 
    2268  
    2269 whd in match sigma_state_pc in ⊢ (% → ?); normalize nodelta @if_elim
    2270 [ #_ >fetch_statement_no_zero [2,4: %] whd in ⊢ (???% → ?); #ABS destruct]
    2271 #EQbl inversion(fetch_internal_function ?? (pc_block (pc ? st))) normalize nodelta
    2272 [2: #err #_ >fetch_statement_no_zero [2,4: %] whd in ⊢ (???% → ?); #ABS destruct]
    2273 * #id1 #fn1 #EQfn normalize nodelta #EQfetch lapply(fetch_statement_inv … EQfetch)
    2274 * >EQfn #EQ destruct normalize nodelta #EQstmt
    2275 cases(multi_fetch_ok … (good fn) ?? EQstmt)
    2276 #list_b_last * #fresh_registers ** #EQlist_b_last #EQfresh_registers
    2277 normalize nodelta * #Instrs * #fresh_registers_spec whd in ⊢ (% → ?);
    2278 @pair_elim #pre_Instrs #last_Instrs #EQInstrs * #dst * #Multi_fetch #STEP_in_code
    2279 #EQeval
    2280 cut((list
    2281    (code_point ERTLptr
    2282     →joint_seq ERTLptr (prog_var_names (joint_function ERTL) ℕ prog)))) [ cases daemon (*Paolo should fix the lemma*)]
    2283 #pre_Instrs'
    2284 cut((code_point ERTLptr
    2285    →joint_seq ERTLptr (prog_var_names (joint_function ERTL) ℕ prog))) [ cases daemon (*Paolo should fix the lemma*)]
    2286 #last_Instrs'
    2287 letin list_map ≝ cic:/matita/basics/lists/list/map.fix(0,3,1)
    2288 cut(∃st''.∃st'''.∃st''''.
    2289     repeat_eval_seq_no_pc (mk_prog_params ERTLptr_semantics (ertl_to_ertlptr prog) stack_size)
    2290      f (translate_internal ? fn) (map_eval ?? pre_Instrs' dst) st = return st''' ∧
    2291     eval_seq_no_pc ? (prog_var_names … (ertl_to_ertlptr prog)) (ev_genv … (mk_prog_params ERTLptr_semantics (ertl_to_ertlptr prog) stack_size))
    2292                       f (translate_internal … fn) (last_Instrs' dst) st''' = return st'''' ∧
    2293     st'' = (mk_state_pc (mk_prog_params ERTLptr_semantics (ertl_to_ertlptr prog) stack_size)
    2294      st'''' (pc_of_point ERTLptr_semantics (pc_block (pc … st)) dst)
    2295                                  (last_pop … st)) ∧
    2296     st' = sigma_state_pc ? good st'')
    2297      [ cases daemon (*to be generalized and TO be moved into an other lemma *)]
    2298 * #st'' * #st''' * #st'''' *** #REPEAT #EVAL_NO_PC_Last #EQst'' #EQst' %{st''} % [assumption]
    2299 lapply(produce_trace_any_any_free … REPEAT)
    2300 [ cases daemon (* Pass dependent *)
    2301 | cases daemon (* should be @Multi_fetch *)
    2302 | @(fetch_internal_function_transf … (λvars. translate_internal …) … EQfn)
    2303 | @dst
    2304 | @list_b_last (*wrong, should dst be destination or the last of list_b_last *)
    2305 ] #TAAF
    2306 lapply(produce_step_trace (mk_prog_params ERTLptr_semantics (ertl_to_ertlptr prog) stack_size)
    2307        (mk_state_pc (mk_prog_params ERTLptr_semantics (ertl_to_ertlptr prog) stack_size)
    2308      st''' (pc_of_point ERTLptr_semantics (pc_block (pc … st)) dst)
    2309                                  (last_pop … st)) f (translate_internal ? fn) (last_Instrs' dst) nxt st'''' (fetch_internal_function_transf … (λvars. translate_internal …) … EQfn)
    2310        ? EVAL_NO_PC_Last) [cases daemon (* should be @STEP_in_code *)]
    2311 #LAST_STEP
    2312 letin taaf_last ≝ (taaf_step ???? TAAF LAST_STEP)
    2313 
    2314         cut(dst = (point_of_pc
    2315                            (mk_prog_params ERTLptr_semantics (ertl_to_ertlptr prog) stack_size)
    2316                            (pc … st))) [cases daemon (*TODO it is true since pre_Instr is empty *)]
    2317                 #EQ <EQ whd in match step_in_code; normalize nodelta
    2318                 cases STEP_in_code #x * #x_spec #x_spec' %{x} %
    2319                 [ >x_spec in ⊢ (??%?); @eq_f @eq_f2 [2: %] cases daemon (*should be % *) |
    2320                  [<EVAL_NO_PC_Last in ⊢ (???%); @eq_f %
    2321 
    2322 
    2323 
    2324 whd in match eval_state; normalize nodelta >EQfetch >m_return_bind
    2325 lapply EQfetch -EQfetch whd in match sigma_state_pc in ⊢ (% → ?);
    2326 normalize nodelta @if_elim
    2327 [ #_ >fetch_statement_no_zero [2,4: %] whd in ⊢ (???% → ?); #ABS destruct]
    2328 #EQbl inversion(fetch_internal_function ?? (pc_block (pc ? st))) normalize nodelta
    2329 [2: #err #_ >fetch_statement_no_zero [2,4: %] whd in ⊢ (???% → ?); #ABS destruct]
    2330 * #id1 #fn1 #EQfn normalize nodelta #EQfetch lapply(fetch_statement_inv … EQfetch)
    2331 * >EQfn #EQ destruct normalize nodelta #EQstmt
    2332 whd in match sigma_state_pc in ⊢ (% → ?); normalize nodelta @if_elim
    2333 [#H >H in EQbl; *] #_ >EQfn normalize nodelta whd in match eval_statement_no_pc;
    2334 normalize nodelta #H @('bind_inversion H) -H #ex_st_nopc
    2335 #H lapply (err_eq_from_io ????? H) -H #EQnopc whd in match eval_statement_advance;
    2336 normalize nodelta whd in match set_no_pc; normalize nodelta
    2337 whd in ⊢ (??%% → ?); #EQ destruct cases(eval_seq_no_pc_no_call_ok … EQnopc)
    2338 #sigma_st_nopc * #EQsigma_st_nopc #sem_rel %
    2339 [ % [@sigma_st_nopc
    2340     | @(succ_pc ERTL_semantics (pc ERTLptr_semantics st) nxt)
    2341     | @(last_pop … st)
    2342     ]
    2343 ] % whd in match sigma_state_pc;
    2344 
    2345 
    2346 
    2347 qed.*)
    2348 
    2349 lemma ertl_to_ertlptr_ok:
    2350 ∀prog.
    2351 let trans_prog ≝ ertl_to_ertlptr prog in
    2352 ∀good : (∀fn.good_state_transformation prog fn).     
    2353 ∀stack_sizes.
    2354    ex_Type1 … (λR.
    2355    status_simulation
    2356     (ERTL_status prog stack_sizes) (ERTLptr_status trans_prog stack_sizes) R).
    2357 #prog #good #stack_size % [@ERTLptrStatusSimulation assumption]
    2358 whd in match status_simulation; normalize nodelta
    2359 whd in match ERTL_status; whd in match ERTLptr_status; normalize nodelta
    2360 whd in ⊢ (% → % → % → % → ?); #st1 #st1' #st2
    2361 change with
    2362   (eval_state ERTL_semantics (prog_var_names ???) ?? = ? → ?) 
    2363 #EQeval @('bind_inversion EQeval)
    2364 ** #id #fn #stmt #H lapply (err_eq_from_io ????? H) -H #EQfetch
    2365 #_  whd in match ERTLptrStatusSimulation; normalize nodelta #EQst2 destruct
    2366 cases stmt in EQfetch; -stmt
    2367 [ * [ #called_id #args #dest| #reg #lbl | #seq] #nxt | #fin_step | *] #EQfetch
    2368 change with (joint_classify ??) in ⊢ (match % with [ _ ⇒ ? | _ ⇒ ? ]);
    2369 [ (*CALL*) cases daemon
    2370 | (*COND*) cases daemon
    2371 | (*seq*) whd in match joint_classify; normalize nodelta >EQfetch >m_return_bind
    2372           normalize nodelta cases (eval_seq_no_call_ok ?????????  EQfetch EQeval)
    2373           #st3 * #EQ destruct *  #taf #tafne %{st3} %{taf} >tafne normalize nodelta
    2374           % [% //] whd >as_label_ok [2:assumption] %
    2375 
    2376 
    2377 lapply(produce_trace_any_any_free
    2378       (mk_prog_params ERTLptr_semantics (ertl_to_ertlptr prog) stack_size)
    2379       st2 id (translate_internal ? fn)) #PRODUCE_TAAF
    2380 cases stmt in EQfetch; -stmt
    2381 [ * [ #called_id #args #dest| #reg #lbl | #seq] #nxt | #fin_step | *] #EQfetch
    2382 normalize nodelta
    2383 
    2384      
    2385 lapply EQfetch -EQfetch whd in match sigma_state_pc in ⊢ (% → ?);
    2386 normalize nodelta @if_elim
    2387 [ #_ >fetch_statement_no_zero [2,4: %] whd in ⊢ (???% → ?); #ABS destruct]
    2388 #EQbl inversion(fetch_internal_function ?? (pc_block (pc ? st2))) normalize nodelta
    2389 [2: #err #_ >fetch_statement_no_zero [2,4: %] whd in ⊢ (???% → ?); #ABS destruct]
    2390 * #id1 #fn1 #EQfn normalize nodelta #EQfetch lapply(fetch_statement_inv … EQfetch)
    2391 * >EQfn #EQ destruct normalize nodelta #EQstmt     
    2392      
    2393       ? ? ?? ? ???)
    2394 
    2395 
    2396 
    2397 cases stmt in EQfetch; -stmt
    2398 [ * [ #called_id #args #dest| #reg #lbl | #seq] #nxt | #fin_step | *] #EQstmt
    2399 change with (joint_classify ??) in ⊢ (match % with [ _ ⇒ ? | _ ⇒ ? ]);
    2400 whd in match joint_classify; normalize nodelta >EQstmt >m_return_bind
    2401 normalize nodelta lapply(fetch_statement_inv … EQstmt) * #fn_spec
    2402 #stmt_spec
    2403 cases(multi_fetch_ok … (good fn) ?? stmt_spec) #f_labs * #f_regs ** #f_labs_spec
    2404 #f_regs_spec normalize nodelta * #list_instr * #b_new_f_regs
    2405 whd in ⊢ (% → ?); normalize nodelta
    2406 [1,2,3: @pair_elim #list_instr1 #rgt #last_ne_spec * #last_lab *
    2407        #list_instr1_spec #last_step
    2408        lapply(fetch_internal_function_transf …
    2409                                        (λvars. translate_internal …) … fn_spec)
    2410        change with ((fetch_internal_function
    2411                     (joint_closed_internal_function ? (prog_var_names … (ertl_to_ertlptr prog)))
    2412                     (globalenv_noinit … (ertl_to_ertlptr prog)) ?) = ?  → ?)
    2413        #EQtrans_fn
    2414        check prog_params
    2415        lapply(produce_trace_any_any_free
    2416        (mk_prog_params ERTLptr_semantics (ertl_to_ertlptr prog) stack_size)
    2417         ? id (translate_internal ? fn) ? ? ?? EQtrans_fn ???) [2: @EQtrans_fn
    2418 
    2419 
    2420 
    2421 
    2422 
    2423 lapply EQstmt whd in match sigma_state_pc in ⊢ (% → ?);
    2424 normalize nodelta @if_elim
    2425 [1,3: #_ >fetch_statement_no_zero [2,4: %] whd in ⊢ (???% → ?); #ABS destruct]
    2426 #EQbl inversion(fetch_internal_function ?? (pc_block (pc ? st2))) normalize nodelta
    2427 [2,4: #err #_ >fetch_statement_no_zero [2,4: %] whd in ⊢ (???% → ?); #ABS destruct]
    2428 * #id1 #fn1 #EQfn1 normalize nodelta #EQstmt1 lapply(fetch_statement_inv … EQstmt1)
    2429 * >EQfn1 #EQ destruct normalize nodelta #EQstmtat
    2430 
    2431 
    2432 
    2433 
    2434 [ (*CALL*)
    2435   cases daemon (*TODO*)
    2436 | whd in match joint_classify; normalize nodelta
    2437  >EQfetch in ⊢ (match % with [ _ ⇒ ? | _ ⇒ ? ]);
    2438   normalize nodelta
    2439  #n_cost
    2440  cases (eval_cond_ok … EQfetch EQeval n_cost)
    2441  #st3 * #EQ destruct * #taf #tafne %{st3} %{taf}
    2442  % [ % [2: %] >tafne normalize nodelta @I] whd >as_label_ok %
    2443 | whd in match joint_classify; normalize nodelta
    2444  >EQfetch in ⊢ (match % with [ _ ⇒ ? | _ ⇒ ? ]);
    2445   normalize nodelta
    2446   cases (eval_seq_no_call_ok ?????????  EQfetch EQeval)
    2447   #st3 * #EQ destruct *  #taf #tafne %{st3} %{taf} >tafne normalize nodelta
    2448   % [% //] whd >as_label_ok [2:assumption] %
    2449 | (*FIN*)
    2450   cases fin_step in EQfetch;
    2451   [ (*GOTO*) #lbl #EQfetch  whd in match joint_classify; normalize nodelta
    2452   >EQfetch in ⊢ (match % with [ _ ⇒ ? | _ ⇒ ? ]); normalize nodelta
    2453     cases (eval_goto_ok … EQfetch EQeval)
    2454     #st3 * #EQ destruct * #taf #tarne %{st3} %{taf} >tarne normalize nodelta
    2455     % [% //] whd >as_label_ok [2:assumption] %
    2456   | (*RETURN*) #EQfetch
    2457      whd in match joint_classify; normalize nodelta
    2458     >EQfetch in ⊢ (match % with [ _ ⇒ ? | _ ⇒ ? ]); normalize nodelta
    2459     cases (eval_return_ok … EQfetch EQeval) #is_ret
    2460     * #st3 * #EQ destruct * #after_ret * #taf ** #taf_prf #EQeval' #ret_prf
    2461     % [2: % [2: % [2: %{(taa_base …)} %{taf}] |*: ] |*:]
    2462     % [2: whd >as_label_ok %] % [2: assumption] % [2: %] % [2: assumption]
    2463     % assumption
    2464   | (*TAILCALL*) #fl #called #args #EQfetch
    2465     cases (eval_tailcall_ok … EQfetch EQeval) #st3 * #EQ destruct * #is_tailcall
    2466     * #is_tailcall' *  #eq_call #EQeval' >is_tailcall normalize nodelta
    2467     #prf  %{«?, is_tailcall'»} %{eq_call}
    2468     % [2: % [2: %{(taa_base …)} %{(taa_base …)}  % [ %{EQeval'} % |] | ] | ]
    2469     whd >as_label_ok %
    2470   ]
    2471 ]
    2472 qed.
    2473 
    2474 @('bind_inversion EQfetch) * #id1 #fn1 #EQfn #H @('bind_inversion H) -H
    2475 #stmt1 #H lapply(opt_eq_from_res ???? H) -H #EQstmt whd in ⊢ (??%% → ?);
    2476 #EQ destruct
    2477 
    2478 (*
    2479 lemma push_ra_ok : ∀prog : ertl_program.
    2480 ∀good :  (∀fn.good_state_transformation prog fn).∀restr.
    2481 preserving21 … res_preserve1 …
    2482      (sigma_state_pc prog good)
    2483      (\l
    2484      (λst.sigma_state prog good st restr)
    2485      (push_ra ERTL_semantics)
    2486      (push_ra ERTLptr_semantics).
    2487 #prog #good #restr #st #pc whd in match push_ra; normalize nodelta @mfr_bind1
    2488 [2: whd in match sigma_stored_pc; normalize nodelta
    2489 
    2490 [2: #x
    2491 
    2492 
    2493 lemma ertlptr_save_frame_ok : ∀prog : ertl_program.
    2494 ∀good : (∀fn.good_state_transformation prog fn).
    2495 ∀id.
    2496     preserving1 … res_preserve1 …
    2497         (sigma_state_pc prog good)
    2498         (λst. match get_internal_function_from_ident
    2499                   ERTL_semantics (prog_var_names … prog)
    2500                   (globalenv_noinit … prog) id with
    2501              [None ⇒ dummy_state
    2502              |Some fd ⇒
    2503                 sigma_state prog good st (added_registers … fd (f_regs … (good fd)))
    2504              ])
    2505         (ertl_save_frame ID it id)
    2506         (ertlptr_save_frame ID it id).
    2507 #prog #good #id #st whd in match ertl_save_frame; whd in match ertlptr_save_frame;
    2508 normalize nodelta @mfr_bind1
    2509 [2: whd in match push_ra; normalize nodelta @mfr_bind1
    2510 xxxxxxxxxxxx
    2511 
    2512 
    2513 
    2514 lemma fetch_statement_commute :
    2515 ∀prog : ertl_program.
    2516 let trans_prog ≝ (ertl_to_ertlptr prog) in
    2517 ∀sigma : sigma_map trans_prog.
    2518 ∀stack_sizes,id,fn,stmt,pc.
    2519 fetch_statement ERTL_semantics
    2520 (globals (mk_prog_params ERTL_semantics prog stack_sizes))
    2521 (ev_genv (mk_prog_params ERTL_semantics prog stack_sizes))
    2522 pc = return 〈id,fn,stmt〉 →
    2523 match stmt with
    2524 [ sequential seq nxt ⇒
    2525     match seq with
    2526     [ CALL ids args dest ⇒
    2527         match ids with
    2528         [ inl i ⇒
    2529           fetch_statement ERTLptr_semantics
    2530           (globals (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2531           (ev_genv (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2532           pc =
    2533           return 〈id,
    2534           translate_internal … fn,
    2535           sequential ?? (CALL ERTLptr ? (inl ?? i) args dest) nxt〉
    2536         | inr p ⇒ ?(*
    2537           ∃reg,lbl.
    2538           fetch_statement ERTLptr_semantics
    2539           (globals (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2540           (ev_genv (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2541            pc = return 〈id,translate_internal … fn,sequential ?? (extension_seq ERTLptr ? (LOW_ADDRESS reg lbl)) nxt〉
    2542            ∧ ∃ nxt'.
    2543            ! pc' ← get_pc_from_label ? ? (ev_genv (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2544                  id nxt;
    2545            fetch_statement ERTLptr_semantics
    2546           (globals (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2547           (ev_genv (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2548            pc' = return 〈id,translate_internal … fn,sequential ?? (step_seq ERTLptr ? (PUSH … (Reg … reg))) nxt'〉
    2549            ∧ ∃ nxt''.
    2550            ! pc' ← get_pc_from_label ? ? (ev_genv (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2551                  id nxt';
    2552            fetch_statement ERTLptr_semantics
    2553           (globals (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2554           (ev_genv (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2555            pc' = return 〈id,translate_internal … fn,sequential ?? (extension_seq ERTLptr ? (HIGH_ADDRESS reg lbl)) nxt''〉
    2556            ∧ ∃ nxt'''.
    2557            ! pc' ← get_pc_from_label ? ? (ev_genv (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2558                  id nxt'';
    2559            fetch_statement ERTLptr_semantics
    2560           (globals (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2561           (ev_genv (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2562            pc' = return 〈id,translate_internal … fn,sequential ?? (step_seq ERTLptr ? (PUSH … (Reg … reg))) nxt'''〉
    2563            ∧ ∃ nxt''''.
    2564            ! pc' ← get_pc_from_label ? ? (ev_genv (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2565                  id nxt''';
    2566            fetch_statement ERTLptr_semantics
    2567           (globals (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2568           (ev_genv (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2569            pc' = return 〈id,translate_internal … fn,sequential ?? (CALL ERTLptr ? (inr ?? p) args dest) nxt''''〉
    2570            ∧ sigma (translate_internal … fn) nxt''' =  return point_of_pc ERTL_semantics pc *)
    2571         ]
    2572     | COND r lbl ⇒
    2573           fetch_statement ERTLptr_semantics
    2574           (globals (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2575           (ev_genv (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2576           pc =
    2577           return 〈id,
    2578           translate_internal … fn,
    2579           sequential ?? (COND ERTLptr ? r lbl) nxt〉
    2580     | step_seq s ⇒
    2581           fetch_statement ERTLptr_semantics
    2582           (globals (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2583           (ev_genv (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2584           pc =
    2585           return 〈id,
    2586           translate_internal … fn,
    2587           sequential ?? (step_seq ERTLptr … (translate_step_seq ? s)) nxt〉
    2588     ]                   
    2589 | final fin ⇒
    2590      fetch_statement ERTLptr_semantics
    2591      (globals (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2592      (ev_genv (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2593      pc = return 〈id,(translate_internal … fn),final … (joint_fin_step_id fin)〉
    2594 | FCOND abs _ _ _ ⇒ Ⓧabs
    2595 ].
    2596 cases daemon
    2597 qed.
    2598 
    2599 lemma eval_seq_no_call_ok :
    2600  ∀prog.
    2601  let trans_prog ≝ ertl_to_ertlptr prog in
    2602  ∀sigma : sigma_map trans_prog.∀stack_sizes.
    2603  (*? →*)
    2604  ∀st,st',f,fn,stmt,nxt.
    2605    fetch_statement ERTL_semantics
    2606      (prog_var_names (joint_function ERTL_semantics) ℕ prog)
    2607     (ev_genv (mk_prog_params ERTL_semantics prog stack_sizes))
    2608     (pc … (sigma_state_pc ? sigma st)) =
    2609       return 〈f, fn,  sequential … (step_seq ERTL … stmt) nxt〉 →
    2610    eval_state ERTL_semantics
    2611    (prog_var_names (joint_function ERTL_semantics) ℕ prog)
    2612    (ev_genv … (mk_prog_params ERTL_semantics prog stack_sizes))
    2613    (sigma_state_pc ? sigma st) =
    2614     return st' →
    2615  ∃st''. st' = sigma_state_pc ? sigma st'' ∧
    2616  ∃taf : trace_any_any_free (ERTLptr_status trans_prog stack_sizes)
    2617   st
    2618   st''.
    2619  bool_to_Prop (taaf_non_empty … taf).
    2620 #prog #sigma #stack_size #st1 #st2 #f #fn #stmt #nxt #EQf whd in match eval_state;
    2621 normalize nodelta >EQf >m_return_bind whd in match eval_statement_advance;
    2622 whd in match eval_statement_no_pc; normalize nodelta
    2623  #H @('bind_inversion H) -H #st_no_pc #EQ lapply(err_eq_from_io ????? EQ) -EQ
    2624 #EQeval whd in ⊢ (??%% → ?); #EQ destruct lapply EQf
    2625 whd in match sigma_state_pc in ⊢ (% → ?); normalize nodelta @if_elim
    2626 [ #EQbl
    2627 | #pc_st1_spec inversion(fetch_internal_function ???) [2: #e #_]
    2628 ]
    2629 [1,2: whd in match dummy_state_pc; whd in match null_pc;
    2630   whd in match fetch_statement; normalize nodelta whd in match fetch_internal_function;
    2631   normalize nodelta lapply(fetch_function_no_zero ??????)
    2632   [2,9: @( «mk_block Code OZ,refl region Code»)
    2633     |1,8: % |3,10: @prog |7,14: #EQ >EQ |*:]  whd in ⊢ (??%% → ?); #EQ destruct]
    2634 * #f1 #fn1 #EQ lapply(jmeq_to_eq ??? EQ) -EQ #fn1_spec normalize nodelta
    2635 whd in match fetch_statement; normalize nodelta >fn1_spec
    2636 >m_return_bind #H @('bind_inversion H) -H #stmt1 #EQ
    2637 lapply(opt_eq_from_res ???? EQ) -EQ #stmt1_spec whd in ⊢ (??%% → ?); #EQ destruct
    2638 lapply EQeval -EQeval whd in match sigma_state_pc in ⊢ (% → ?);
    2639 normalize nodelta @if_elim [#H >H in pc_st1_spec; *] #_ >fn1_spec
    2640 normalize nodelta #EQeval cases(eval_seq_no_pc_no_call_ok ???????? EQeval)
    2641 #st_no_pc' * #EQeval' #EQst_no_pc'
    2642 whd in match set_no_pc; normalize nodelta
    2643 % [ % [@st_no_pc'|@(succ_pc ERTL_semantics (pc ERTL_semantics (sigma_state_pc prog sigma st1))
    2644    nxt)| @(last_pop ? st1)]]
    2645 % [ whd in match sigma_state_pc; normalize nodelta
    2646     @if_elim [#H >H in pc_st1_spec; *] #_ >fn1_spec normalize nodelta
    2647     @if_elim [#H >H in pc_st1_spec; *] #_ >fn1_spec normalize nodelta
    2648     >EQst_no_pc' %]
    2649 %{(taaf_step … (taa_base …) …)}
    2650 [3: //] lapply(fetch_statement_commute ? sigma ????? EQf) normalize nodelta
    2651 whd in match sigma_state_pc; normalize nodelta
    2652 @if_elim [1,3:#H >H in pc_st1_spec; *] #_ >fn1_spec normalize nodelta
    2653 #EQf1
    2654 [ whd in match as_classifier; normalize nodelta whd in match (as_classify ??);
    2655   >EQf1 normalize nodelta %
    2656 | whd in match (as_execute ???); whd in match eval_state; normalize nodelta
    2657   >EQf1 >m_return_bind whd in match eval_statement_no_pc; normalize nodelta
    2658   >EQeval' >m_return_bind %
    2659 ]
    2660 qed.
    2661 
    2662 
    2663 lemma eval_goto_ok :
    2664  ∀prog : ertl_program.
    2665  let trans_prog ≝ ertl_to_ertlptr prog in
    2666  ∀stack_sizes.
    2667  ∀sigma : sigma_map trans_prog.
    2668  ∀st,st',f,fn,nxt.
    2669    fetch_statement ERTL_semantics …
    2670     (globalenv_noinit ? prog) (pc … (sigma_state_pc ? sigma st)) =
    2671       return 〈f, fn,  final … (GOTO ERTL … nxt)〉 →
    2672    eval_state ERTL_semantics
    2673    (prog_var_names (joint_function ERTL_semantics) ℕ prog)
    2674    (ev_genv … (mk_prog_params ERTL_semantics prog stack_sizes))
    2675    (sigma_state_pc ? sigma st) =
    2676     return st' →
    2677     ∃ st''. st' = sigma_state_pc ? sigma st'' ∧
    2678  ∃taf : trace_any_any_free (ERTLptr_status trans_prog stack_sizes)
    2679   st
    2680   st''.
    2681  bool_to_Prop (taaf_non_empty … taf).
    2682 #prog #stack_sizes #sigma #st #st' #f #fn #nxt
    2683 whd in match sigma_state_pc in ⊢ (% → ?); normalize nodelta
    2684 @if_elim
    2685 [ #EQbl whd in match dummy_state_pc; whd in match null_pc;
    2686   whd in match fetch_statement; whd in match fetch_internal_function;
    2687   normalize nodelta lapply(fetch_function_no_zero ??????)
    2688   [2: @( «mk_block Code OZ,refl region Code»)
    2689     | % | @prog |7: #EQ >EQ |*:]  whd in ⊢ (??%% → ?); #EQ destruct]
    2690 #Hbl inversion(fetch_internal_function ???)
    2691 [2: #e #_ normalize nodelta whd in match dummy_state_pc; whd in match null_pc;
    2692    whd in match fetch_statement; whd in match fetch_internal_function;
    2693   normalize nodelta lapply(fetch_function_no_zero ??????)
    2694   [2: @( «mk_block Code OZ,refl region Code»)
    2695     | % | @prog |7: #EQ >EQ |*:]  whd in ⊢ (??%% → ?); #EQ destruct]
    2696 * #f1 #fn1 #EQ lapply(jmeq_to_eq ??? EQ) -EQ #fn1_spec normalize nodelta
    2697 #EQf lapply EQf whd in match fetch_statement; normalize nodelta >fn1_spec
    2698 >m_return_bind #H @('bind_inversion H) -H #stmt' #_ whd in ⊢ (??%% → ?);
    2699 #EQ destruct whd in match sigma_state_pc in ⊢ (% → ?); normalize nodelta
    2700 @if_elim [#H >H in Hbl; *] #_ >fn1_spec normalize nodelta whd in match eval_state;
    2701 normalize nodelta >EQf >m_return_bind whd in match eval_statement_advance;
    2702 whd in match eval_statement_no_pc; normalize nodelta >m_return_bind
    2703 whd in match goto; normalize nodelta #H lapply (err_eq_from_io ????? H) -H
    2704 #H @('bind_inversion H) -H #pc' whd in match set_no_pc; normalize nodelta
    2705 >(pc_of_label_eq … fn1_spec) whd in ⊢ (???% → ?); #EQ whd in ⊢ (??%% → ?); #EQ1
    2706 destruct lapply (fetch_statement_commute … sigma … stack_sizes … EQf)
    2707 normalize nodelta #EQf' %
    2708 [ % [ @st
    2709     | @(mk_program_counter
    2710          (pc_block (pc ERTLptr_semantics st))
    2711          (offset_of_point ERTL_semantics nxt))
    2712     | @(last_pop … st)
    2713     ]
    2714 ] %
    2715 [ whd in match sigma_state_pc; normalize nodelta @if_elim [#H >H in Hbl; *]
    2716   >fn1_spec normalize nodelta #_ % ]
    2717 %{(taaf_step … (taa_base …) …)}
    2718 [ whd in match as_classifier; normalize nodelta whd in match (as_classify ??);
    2719   >EQf' normalize nodelta %
    2720 | whd in match (as_execute ???); whd in match eval_state; normalize nodelta
    2721   >EQf' >m_return_bind whd in match eval_statement_no_pc;
    2722   whd in match eval_statement_advance; normalize nodelta >m_return_bind
    2723   whd in match goto; normalize nodelta whd in match pc_of_label; normalize nodelta
    2724   lapply(fetch_internal_function_transf ??????? fn1_spec)
    2725   [ #vars @translate_internal |] #EQ >EQ >m_return_bind %
    2726 | %
    2727 ]
    2728 qed.
    2729 *)
    2730 
    2731 
    2732                        
    2733 
    2734  
    2735 lemma eval_return_ok :
    2736 ∀prog : ertl_program.
    2737 let trans_prog ≝ ertl_to_ertlptr prog in
    2738 ∀stack_sizes.
    2739 ∀sigma : sigma_map trans_prog.
    2740 ∀st,st',f,fn.
    2741  fetch_statement ERTL_semantics …
    2742   (globalenv_noinit ? prog) (pc … (sigma_state_pc ? sigma st)) =
    2743     return 〈f, fn,  final … (RETURN ERTL … )〉 →
    2744  eval_state ERTL_semantics
    2745    (prog_var_names (joint_function ERTL_semantics) ℕ prog)
    2746    (ev_genv … (mk_prog_params ERTL_semantics prog stack_sizes))
    2747    (sigma_state_pc ? sigma st) =
    2748   return st' →
    2749 joint_classify (mk_prog_params ERTLptr_semantics trans_prog stack_sizes)
    2750   st = Some ? cl_return ∧
    2751 ∃ st''. st' = sigma_state_pc ? sigma st'' ∧
    2752 ∃st2_after_ret.
    2753 ∃taf : trace_any_any_free (ERTLptr_status trans_prog stack_sizes)
    2754 st2_after_ret
    2755 st''.
    2756 (if taaf_non_empty … taf then
    2757   ¬as_costed (ERTLptr_status trans_prog stack_sizes)
    2758     st2_after_ret
    2759  else True) ∧
    2760 eval_state … (ev_genv …  (mk_prog_params ERTLptr_semantics trans_prog stack_sizes)) st =
    2761 return st2_after_ret ∧
    2762 ret_rel ?? (ERTLptrStatusSimulation prog stack_sizes sigma) st' st2_after_ret.
    2763 #prog #stack_size #sigma #st #st' #f #fn
    2764 whd in match sigma_state_pc in ⊢ (% → ?); normalize nodelta
    2765 @if_elim
    2766 [ #EQbl whd in match dummy_state_pc; whd in match null_pc;
    2767   whd in match fetch_statement; whd in match fetch_internal_function;
    2768   normalize nodelta >(fetch_function_no_zero ??????) [2: %]
    2769   whd in ⊢ (??%% → ?); #EQ destruct ]
    2770 #Hbl inversion(fetch_internal_function ???)
    2771 [2: #e #_ normalize nodelta whd in match dummy_state_pc; whd in match null_pc;
    2772    whd in match fetch_statement; whd in match fetch_internal_function;
    2773   normalize nodelta lapply(fetch_function_no_zero ??????)
    2774   [2: @( «mk_block Code OZ,refl region Code»)
    2775     | % | @prog |7: #EQ >EQ |*:]  whd in ⊢ (??%% → ?); #EQ destruct]
    2776 * #f1 #fn1 #EQ lapply(jmeq_to_eq ??? EQ) -EQ #fn1_spec normalize nodelta
    2777 #EQf lapply EQf whd in match fetch_statement; normalize nodelta >fn1_spec
    2778 >m_return_bind #H @('bind_inversion H) -H #stmt' #_ whd in ⊢ (??%% → ?);
    2779 #EQ destruct whd in match sigma_state_pc in ⊢ (% → ?); normalize nodelta
    2780 @if_elim [#H >H in Hbl; *] #_ >fn1_spec normalize nodelta
    2781 whd in match eval_state; normalize nodelta >EQf >m_return_bind
    2782 whd in match eval_statement_no_pc; whd in match eval_statement_advance;
    2783 normalize nodelta >m_return_bind
    2784 #H lapply (err_eq_from_io ????? H) -H #H @('bind_inversion H) -H
    2785 * #st1 #pc1 #EQpop whd in match next_of_call_pc; normalize nodelta
    2786 >m_bind_bind #H @('bind_inversion H) -H ** #f1 #fn1 * normalize nodelta
    2787 [ * [ #c_id #args #dest | #r #lbl | #seq ] #nxt | #fin | * ]
    2788 #EQf1 normalize nodelta [2,3,4: whd in ⊢ (??%% → ?); #EQ destruct]
    2789 >m_return_bind whd in ⊢ (??%% → ?); #EQ destruct
    2790 lapply (fetch_statement_commute prog sigma stack_size … EQf)
    2791 normalize nodelta #EQf'
    2792 % [ whd in match joint_classify; normalize nodelta >EQf' >m_return_bind %]
    2793 change with (pop_ra ?? = ?) in EQpop; whd in match set_no_pc in EQpop;
    2794 normalize nodelta in EQpop;
    2795 cases(pop_ra_ok ? sigma  stack_size fn ?? EQpop) * #st3 #pc3 * #st3_spec
    2796 normalize nodelta #EQ destruct whd in match set_last_pop; whd in match succ_pc;
    2797 normalize nodelta whd in match (point_of_succ ???);
    2798  % [ % [ @st3 | @(pc_of_point ERTL_semantics (pc_block … pc3) nxt) | @pc3] ]
    2799  % [  @('bind_inversion EQf1) * #f3 #fn3 whd in match sigma_stored_pc;
    2800       normalize nodelta inversion(sigma_pc_opt ???) normalize nodelta
    2801       [ #_ #H @('bind_inversion H) -H #x whd in match null_pc; normalize nodelta
    2802         >fetch_function_no_zero [2: %] whd in ⊢ (???% → ?); #EQ destruct
    2803       | #pc4 whd in match sigma_pc_opt; normalize nodelta @if_elim
    2804         [ #bl3_spec @('bind_inversion EQf1) #x #H @('bind_inversion H) -H
    2805           #x1 >fetch_function_no_minus_one [ whd in ⊢ (???% → ?); #EQ destruct]
    2806           lapply bl3_spec @eqZb_elim #EQ * whd in match sigma_stored_pc;
    2807           normalize nodelta whd in match sigma_pc_opt; normalize nodelta
    2808            >bl3_spec normalize nodelta assumption
    2809         | #bl3_spec #H @('bind_inversion H) -H * #id4 #fn4
    2810           #H lapply(res_eq_from_opt ??? H) -H #fn4_spec
    2811           #H @('bind_inversion H) -H #lbl4 #lbl4_spec whd in ⊢ (??%? → ?); #EQ
    2812           destruct #fn3_spec #H @('bind_inversion H) -H #stmt1 #_
    2813           whd in ⊢ (??%% → ?); #EQ destruct
    2814           >(fetch_internal_function_transf … fn3_spec) in fn4_spec;
    2815           whd in ⊢ (??%% → ?); #EQ destruct
    2816         ]
    2817       ]
    2818       whd in match sigma_state_pc; normalize nodelta @if_elim
    2819       [ >(pc_block_eq prog sigma ????) in bl3_spec;
    2820        [2: >lbl4_spec % #ABS destruct
    2821        |3: >(fetch_internal_function_transf … fn3_spec) % |*:]
    2822        #bl3_spec whd in match pc_of_point; normalize nodelta #EQ >EQ in bl3_spec; *
    2823       | #_ cases daemon
    2824       ]
    2825   ] cases daemon
    2826 qed.
    2827 
    2828 (*
    2829 lemma ertl_allocate_local_ok : ∀ prog : ertl_program.
    2830 let trans_prog ≝ ertl_to_ertlptr prog in
    2831 ∀sigma : sigma_map.
    2832 ∀stack_size.
    2833 ∀id,regs.
    2834 ertl_allocate_local id (sigma_regs ? sigma getLocalsFromId(
    2835 *)
    2836 
    2837 lemma eval_tailcall_ok :
    2838 ∀prog.
    2839 let trans_prog ≝ ertl_to_ertlptr prog in
    2840 ∀stack_sizes.
    2841 ∀sigma : sigma_map trans_prog.
    2842 ∀st,st',f,fn,fl,called,args.
    2843  fetch_statement ERTL_semantics …
    2844   (globalenv_noinit ? prog) (pc … (sigma_state_pc ? sigma st)) =
    2845     return 〈f, fn,  final … (TAILCALL ERTL … fl called args)〉 →
    2846  eval_state ERTL_semantics
    2847    (prog_var_names (joint_function ERTL_semantics) ℕ prog)
    2848    (ev_genv … (mk_prog_params ERTL_semantics prog stack_sizes))
    2849    (sigma_state_pc ? sigma st) =
    2850   return st' →
    2851   ∃ st''. st' = sigma_state_pc ? sigma st'' ∧
    2852   ∃is_tailcall, is_tailcall'.
    2853   joint_tailcall_ident (mk_prog_params ERTLptr_semantics trans_prog stack_sizes) «st, is_tailcall'» =
    2854   joint_tailcall_ident (mk_prog_params ERTL_semantics prog stack_sizes) «(sigma_state_pc ? sigma st), is_tailcall» ∧
    2855   eval_state … (ev_genv … (mk_prog_params ERTLptr_semantics trans_prog stack_sizes))
    2856     st = return st''.
    2857 #prog #stack_size #sigma #st #st' #f #fn #fl #called #args
    2858 whd in match sigma_state_pc in ⊢ (% → ?); normalize nodelta
    2859 @if_elim
    2860 [ #EQbl whd in match dummy_state_pc; whd in match null_pc;
    2861   whd in match fetch_statement; whd in match fetch_internal_function;
    2862   normalize nodelta >(fetch_function_no_zero ??????) [2: %]
    2863   whd in ⊢ (??%% → ?); #EQ destruct ]
    2864 #Hbl inversion(fetch_internal_function ???)
    2865 [2: #e #_ normalize nodelta whd in match dummy_state_pc; whd in match null_pc;
    2866    whd in match fetch_statement; whd in match fetch_internal_function;
    2867   normalize nodelta lapply(fetch_function_no_zero ??????)
    2868   [2: @( «mk_block Code OZ,refl region Code»)
    2869     | % | @prog |7: #EQ >EQ |*:]  whd in ⊢ (??%% → ?); #EQ destruct]
    2870 * #f1 #fn1 #EQ lapply(jmeq_to_eq ??? EQ) -EQ #fn1_spec normalize nodelta
    2871 #EQf lapply EQf whd in match fetch_statement; normalize nodelta >fn1_spec
    2872 >m_return_bind #H @('bind_inversion H) -H #stmt' #_ whd in ⊢ (??%% → ?);
    2873 #EQ destruct  whd in match sigma_state_pc in ⊢ (% → ?); normalize nodelta
    2874 @if_elim [#H >H in Hbl; *] #_ >fn1_spec normalize nodelta
    2875 whd in match eval_state; normalize nodelta >EQf >m_return_bind
    2876 whd in match eval_statement_no_pc; whd in match eval_statement_advance;
    2877 normalize nodelta >m_return_bind whd in match eval_tailcall;
    2878 normalize nodelta #H @('bind_inversion H) -H #bl whd in match set_no_pc;
    2879 normalize nodelta #bl_spec #H @('bind_inversion H) -H * #id1 * [#int_f | #ext_f] 
    2880 #H lapply(err_eq_from_io ????? H) -H #id1_spec normalize nodelta
    2881 [2: #H @('bind_inversion H) -H #st1 whd in match eval_external_call; normalize nodelta
    2882     #H @('bind_inversion H) -H #l_val #_ #H @('bind_inversion H) -H #le #_
    2883     #H @('bind_inversion H) -H #x whd in match do_io; normalize nodelta
    2884     whd in ⊢ (???% → ?); #EQ destruct ]
    2885 #H lapply(err_eq_from_io ????? H) -H  #H @('bind_inversion H) -H #st1
    2886 whd in match eval_internal_call; normalize nodelta whd in match (stack_sizes ????);
    2887 #H @('bind_inversion H) -H #n #H lapply(opt_eq_from_res ???? H) -H #n_spec
    2888 whd in match(setup_call ???????); >m_return_bind
    2889 whd in ⊢ (??%% → ?); #EQ destruct whd in match sigma_state in ⊢ (% → ?);
    2890 normalize  nodelta whd in ⊢ (??%% → ?); #EQ destruct
    2891 % [ %
    2892     [ %
    2893       [ @(st_frms ERTLptr_semantics st)
    2894       | @(istack ERTLptr_semantics st)
    2895       | @(carry ERTLptr_semantics st)
    2896       | cases daemon
    2897       | @(m ERTLptr_semantics st)
    2898       ]
    2899     | @(mk_program_counter bl
    2900             (offset_of_point ERTL_semantics
    2901               (joint_if_entry ERTL_semantics
    2902                   (prog_var_names (joint_function ERTL_semantics) ℕ prog) int_f)))
    2903     | @(last_pop ERTLptr_semantics st)
    2904     ]
    2905   ]
    2906 % [ whd in match sigma_state_pc; normalize nodelta @if_elim whd in match pc_of_point;
    2907     normalize nodelta
    2908     [ #Hbl >fetch_function_no_minus_one in id1_spec;
    2909        [2: lapply Hbl @eqZb_elim -Hbl #Hbl * @Hbl] whd in ⊢ (???% → ?);
    2910        #EQ destruct(EQ)
    2911     ] #_ whd in match fetch_internal_function; normalize nodelta >id1_spec
    2912       >m_return_bind normalize nodelta cases daemon (*TO BE COmpleted *)
    2913   ] cases daemon (*TO BE COMPLETED*)
    2914 qed.
    2915    
    2916    
    2917    
    2918    
    2919 lemma as_label_ok : ∀ prog : ertl_program.
    2920 let trans_prog ≝ ertl_to_ertlptr prog in
    2921 ∀ sigma : sigma_map trans_prog.
    2922 ∀stack_sizes.
    2923 ∀ st.
    2924 as_label (ERTLptr_status trans_prog stack_sizes) st = as_label
    2925 (ERTL_status prog stack_sizes) (sigma_state_pc prog sigma st).
    2926 #prog #sigma #stack_size * #st #pc #lp
    2927 whd in match as_label; normalize nodelta whd in match (as_pc_of ??) in ⊢ (??%%);
    2928 whd in match (as_label_of_pc ??) in ⊢ (??%%);
    2929 
    2930 
    2931 (*
    2932 
    2933 whd in match fetch_statement; normalize nodelta
    2934 whd in match sigma_state_pc; normalize nodelta @if_elim
    2935 [ #EQbl whd in match fetch_internal_function; normalize nodelta >m_bind_bind
    2936  lapply(fetch_function_no_minus_one ??????) [2: @(pc_block pc) | lapply EQbl
    2937  @eqZb_elim #H * @H| @(ertl_to_ertlptr prog) |7: #EQ >EQ |*:] normalize nodelta
    2938  whd in match dummy_state_pc; whd in match (as_label_of_pc ??); whd in match null_pc;
    2939  whd in match fetch_statement; normalize nodelta whd in match fetch_internal_function;
    2940  normalize nodelta >m_bind_bind
    2941  lapply(fetch_function_no_zero ??????) [2: @( «mk_block Code OZ,refl region Code»)
    2942  | % | @prog |7: #EQ >EQ |*:] %
    2943 | inversion ( fetch_internal_function
    2944      (joint_closed_internal_function ERTL
    2945       (prog_var_names (joint_function ERTL) ℕ prog))
    2946      (globalenv_noinit (joint_function ERTL) prog) (pc_block pc))
    2947  [ * #id #fn #fn_spec #_ lapply(fetch_internal_function_transf ??????? fn_spec)
    2948    [ @(λvars,fn.translate_internal … fn) |] #EQ >EQ >m_return_bind normalize nodelta
    2949      whd in match (as_label_of_pc ??);
    2950      whd in match fetch_statement; normalize nodelta >fn_spec >m_return_bind
    2951      cases daemon (*serve specifica su sigma TODO*)
    2952    | #err #EQ lapply(jmeq_to_eq ??? EQ) -EQ #fetch_err #_ normalize nodelta
    2953      whd in match dummy_state_pc;
    2954      whd in match (as_label_of_pc ??); whd in match null_pc;
    2955      whd in match fetch_statement; normalize nodelta
    2956      whd in match fetch_internal_function in ⊢ (???%);
    2957      normalize nodelta
    2958      lapply(fetch_function_no_zero ??????) [2: @( «mk_block Code OZ,refl region Code»)
    2959      | % | @prog |7: #EQ >EQ in ⊢ (???%); |*:] normalize nodelta -EQ
    2960      lapply fetch_err -fetch_err whd in match fetch_internal_function; normalize nodelta
    2961      inversion(fetch_function ???)
    2962      [* #id * #fn #fn_spec >m_return_bind normalize nodelta [whd in ⊢ (??%? → ?); #EQ destruct]
    2963      #EQ destruct  lapply(jmeq_to_eq ??? fn_spec) -fn_spec #fn_spec
    2964      lapply(fetch_function_transf ????????? fn_spec) [ #v  @transf_fundef [2:@translate_internal |]|]
    2965      #EQ >EQ >m_return_bind %
    2966    | #err1 #EQ lapply(jmeq_to_eq ??? EQ) -EQ #EQfetch whd in ⊢ (??%? → ?); #EQ destruct
    2967      normalize nodelta lapply EQfetch -EQfetch whd in match fetch_function;
    2968      normalize nodelta check joint_function
    2969       lapply(symbol_for_block_transf  ? ? ? ? prog (λvars.?)  (pc_block pc))
    2970       [@transf_fundef [2: @translate_internal|] |4: #EQ >EQ in ⊢ (? → %); |*:] 
    2971      cases(symbol_for_block ???) [ whd in ⊢ (??%% → ?); #EQ destruct %]
    2972      #id >m_return_bind inversion(find_funct_ptr ???)
    2973      [2: #fn1 #_ >m_return_bind whd in ⊢ (??%? → ?); #EQ destruct]
    2974      #EQf whd in ⊢ (??%? → ?); #EQ destruct
    2975      lapply(find_funct_ptr_none ??????? EQf) (*forse e' falso*)
    2976      [#vars @transf_fundef [2: @translate_internal|]|]
    2977      #EQ >EQ %
    2978      ]
    2979   ]
    2980 ]*)
    2981 cases daemon
    2982 qed.
    2983 
    2984 lemma bool_of_beval_ok : ∀prog : ertlptr_program.
    2985 ∀sigma : sigma_map prog.
    2986 preserving1 … res_preserve1 …
    2987     (sigma_beval prog sigma)
    2988     (λx.x)
    2989     (bool_of_beval)
    2990     (bool_of_beval).
    2991 #prog #sigma whd in match bool_of_beval; normalize nodelta
    2992 * normalize nodelta
    2993  [ | | #ptr1 #ptr2 #p | #by | #p | #ptr #p | #pc #p]
    2994 try @res_preserve_error1 #x
    2995 [1,2,3,4: whd in ⊢ (???% → ?); #EQ destruct
    2996           [1,4: %{true} % //
    2997           |3: %{false} % //
    2998           | %{(eq_bv 8 (zero 8) by)} % //
    2999           ]
    3000 | whd in match sigma_beval; normalize nodelta cases(sigma_pc_opt ? ? ?)
    3001   normalize nodelta [2: #pc1] whd in ⊢ (???% → ?); #EQ destruct
    3002 ]
    3003 qed.
    3004 
    3005 lemma eval_cond_ok :
    3006 ∀prog.
    3007 let trans_prog ≝ ertl_to_ertlptr prog in
    3008 ∀stack_sizes.
    3009 ∀sigma : sigma_map trans_prog.
    3010 ∀st,st',f,fn,a,ltrue,lfalse.
    3011  fetch_statement ERTL_semantics …
    3012   (globalenv_noinit ? prog) (pc … (sigma_state_pc ? sigma st)) =
    3013     return 〈f, fn,  sequential … (COND ERTL … a ltrue) lfalse〉 →
    3014  eval_state ERTL_semantics
    3015    (prog_var_names (joint_function ERTL_semantics) ℕ prog)
    3016    (ev_genv … (mk_prog_params ERTL_semantics prog stack_sizes))
    3017    (sigma_state_pc ? sigma st) =
    3018   return st' →
    3019 as_costed (ERTL_status prog stack_sizes)
    3020   st' →
    3021 ∃ st''. st' = sigma_state_pc ? sigma st'' ∧
    3022 ∃taf : trace_any_any_free (ERTLptr_status trans_prog stack_sizes)
    3023 st st''.
    3024 bool_to_Prop (taaf_non_empty … taf).
    3025 #prog #stack_size #sigma #st #st' #f #fn #a #lb_t #lb_f
    3026 whd in match sigma_state_pc in ⊢ (% → ?); normalize nodelta
    3027 @if_elim
    3028 [ #EQbl whd in match dummy_state_pc; whd in match null_pc;
    3029   whd in match fetch_statement; whd in match fetch_internal_function;
    3030   normalize nodelta >(fetch_function_no_zero ??????) [2: %]
    3031   whd in ⊢ (??%% → ?); #EQ destruct ]
    3032 #Hbl inversion(fetch_internal_function ???)
    3033 [2: #e #_ normalize nodelta whd in match dummy_state_pc; whd in match null_pc;
    3034    whd in match fetch_statement; whd in match fetch_internal_function;
    3035   normalize nodelta >(fetch_function_no_zero ??????) [2: %]
    3036  whd in ⊢ (??%% → ?); #EQ destruct]
    3037 * #f1 #fn1 #EQ lapply(jmeq_to_eq ??? EQ) -EQ #fn1_spec normalize nodelta
    3038 #EQf lapply EQf whd in match fetch_statement; normalize nodelta >fn1_spec
    3039 >m_return_bind #H @('bind_inversion H) -H #stmt' #_ whd in ⊢ (??%% → ?);
    3040 #EQ destruct whd in match eval_state; whd in match eval_statement_no_pc;
    3041 whd in match eval_statement_advance; whd in match sigma_state_pc in ⊢ (% → ?);
    3042 normalize nodelta @if_elim [#H >H in Hbl; *] #_ >fn1_spec normalize nodelta
    3043 >EQf >m_return_bind normalize nodelta >m_return_bind
    3044 #H lapply(err_eq_from_io ????? H) -H #H @('bind_inversion H) -H #bv
    3045 change with (ps_reg_retrieve ?? = ? → ?) whd in match set_no_pc;
    3046 whd in match sigma_state in ⊢ (??(?%?)? → ?); normalize nodelta #bv_spec
    3047 #H @('bind_inversion H) -H * #EQbv normalize nodelta
    3048 [ whd in match goto; normalize nodelta >pc_of_label_eq [2: assumption |3:]
    3049   >m_return_bind whd in match pc_of_point; normalize nodelta whd in ⊢ (??%% → ?);
    3050   whd in match set_pc; normalize nodelta #EQ destruct
    3051 | whd in match next; whd in match set_pc; normalize nodelta whd in match (succ_pc ???);
    3052   whd in match (point_of_succ ???); whd in ⊢ (??%% → ?); #EQ destruct
    3053 ]
    3054 whd in match as_costed; normalize nodelta * #n_cost %
    3055 [1,3: % [1,4: @st
    3056         |2,5: @(mk_program_counter
    3057                   (pc_block (pc ERTLptr_semantics st))
    3058                   (offset_of_point ERTL_semantics ?)) [ @lb_t | @lb_f]
    3059         |3,6: @(last_pop ? st)
    3060         ]
    3061 ]
    3062 % [1,3: whd in match sigma_state_pc; normalize nodelta @if_elim
    3063        [1,3: #EQ >EQ in Hbl; *] #_ >fn1_spec %]
    3064 %{(taaf_step_jump … (taa_base …) …) I}
    3065 lapply (fetch_statement_commute prog sigma … stack_size … EQf)
    3066 normalize nodelta #EQf'
    3067 [1,4: whd in match as_costed; normalize nodelta >as_label_ok [2,4: @sigma]
    3068       % #H @n_cost <H whd in match sigma_state_pc; normalize nodelta
    3069       @if_elim [1,3: #EQ >EQ in Hbl; *] #_ >fn1_spec %
    3070 |2,5: whd in match as_classifier; normalize nodelta  whd in match (as_classify ??);
    3071       normalize nodelta >EQf' %
    3072 |*:  whd in match (as_execute ???); whd in match eval_state; normalize nodelta
    3073      >EQf' >m_return_bind whd in match eval_statement_no_pc; normalize nodelta
    3074      >m_return_bind whd in match eval_statement_advance; normalize nodelta 
    3075      change with (ps_reg_retrieve ??) in ⊢ (??(????(????%?))?);
    3076      cases(ps_reg_retrieve_ok ????? ? bv_spec) #bv' * #bv_spec' #bv_bv'
    3077      >bv_spec' >m_return_bind >bv_bv' in EQbv; #EQbv
    3078      cases(bool_of_beval_ok ? sigma ? ? EQbv) #b1 * #b1_spec #EQ destruct
    3079      >b1_spec >m_return_bind normalize nodelta [2: %] whd in match goto;
    3080      normalize nodelta whd in match set_no_pc; normalize nodelta
    3081      >pc_of_label_eq
    3082      [ %
    3083      | lapply(fetch_internal_function_transf ????????)
    3084        [3: @f |2: @fn | whd in ⊢ (???%); <fn1_spec in ⊢ (???%); %
    3085        | | #vars @translate_internal |9: #EQ >EQ in ⊢ (??%?); % |*:]
    3086        |
    3087      ]
    3088 ]
    3089 qed.
    3090        
    3091 
    3092 lemma
    3093   find_funct_ptr_none:
    3094     ∀A,B,V,iV. ∀p: program A V. ∀transf: (∀vs. A vs → B vs).
    3095     ∀b: block.
    3096     find_funct_ptr ? (globalenv … iV p) b = None ? →
    3097     find_funct_ptr ? (globalenv … iV (transform_program … p transf)) b = None ?.
    3098 #A #B #V #i #p #transf #b
    3099 whd in match find_funct_ptr; normalize nodelta
    3100 cases b -b * normalize nodelta [#x #_ %] * normalize nodelta
    3101 [1,2: [2: #x] #_ %] #x whd in match globalenv; normalize nodelta
    3102 whd in match globalenv_allocmem; normalize nodelta
    3103 cases daemon (*forse e' falso *)
    3104 qed.
    3105 
    3106 
    3107 
    3108 
    3109 
    3110 
    3111 
     2599 qed. *)
  • src/ERTLptr/ERTLptr.ma

    r2674 r2783  
    2424    (* has_tailcall ≝ *) false
    2525    (* paramsT ≝ *) ℕ.
     26   
     27definition ERTLptr_functs ≝ mk_get_pseudo_reg_functs ERTLptr_uns
     28(* acc_a_regs *) (λr.[r])
     29(* acc_b_regs *) (λr.[r])
     30(* acc_a_args *) (λarg.match arg with [ Imm _ ⇒ [ ] | Reg r ⇒ [r]])
     31(* acc_b_args *) (λarg.match arg with [ Imm _ ⇒ [ ] | Reg r ⇒ [r]])
     32(* dpl_regs *) (λr.[r])
     33(* dph_regs *) (λr.[r])
     34(* dpl_args *) (λarg.match arg with [ Imm _ ⇒ [ ] | Reg r ⇒ [r]])
     35(* dph_args *) (λarg.match arg with [ Imm _ ⇒ [ ] | Reg r ⇒ [r]])
     36(* snd_args *) (λarg.match arg with [ Imm _ ⇒ [ ] | Reg r ⇒ [r]])
     37(* pair_move_regs *) (λx.(regs_from_move_dst (\fst x)) @ (regs_from_move_src (\snd x)))
     38(* f_call_args *) (λ_.[ ])
     39(* f_call_dest *) (λ_.[ ])
     40(* ext_seq_regs *)
     41  (λs.match s with [ LOW_ADDRESS r _ ⇒ [r]
     42                   | HIGH_ADDRESS r _ ⇒ [r]
     43                   | ertlptr_ertl s' ⇒ ertl_ext_seq_regs s'
     44                   ])
     45(* params_regs *) (λ_.[ ]).
    2646
    27 definition ERTLptr ≝ mk_graph_params ERTLptr_uns.
     47definition ERTLptr ≝ mk_graph_params (mk_uns_params ERTLptr_uns ERTLptr_functs).
    2848definition ertlptr_program ≝ joint_program ERTLptr.
    2949 
  • src/ERTLptr/ERTLptr_semantics.ma

    r2666 r2783  
    55
    66definition ertlptr_save_frame:
    7  call_kind → unit → ident → state_pc ERTL_state → res (state … ERTL_state) ≝
    8  λk.λ_.λid.λst.
    9  do st ← match k with [ID ⇒ push_ra … st (pc … st) |
    10  PTR ⇒ return (st_no_pc … st)] ; OK …
    11    (set_frms ERTL_state (〈\fst (regs ERTL_state st),id〉 :: (st_frms … st))
    12     (set_regs ERTL_state 〈empty_map …,\snd (regs … st)〉 st)).
     7 call_kind → unit  → state_pc ERTL_state → res (state … ERTL_state) ≝
     8 λk.λ_.λst.
     9 ! st' ← match k with
     10  [ ID ⇒ push_ra … st (pc … st)
     11  | PTR ⇒ return (st : state ?)
     12  ] ;
     13 ! frms ← opt_to_res ? [MSG FrameErrorOnPush] (st_frms … st');
     14  return
     15   (set_frms ERTL_state (〈\fst (regs ERTL_state st'), pc_block (pc … st)〉 :: frms)
     16    (set_regs ERTL_state 〈empty_map …,\snd (regs … st')〉 st')).
    1317
    1418definition eval_ertlptr_seq:
     
    5357     λst.return map ?? (hwreg_retrieve (\snd (regs … st))) RegisterRets)
    5458  (* eval_ext_seq       ≝ *) (λgl,ge,stm,id.λ_.eval_ertlptr_seq F gl ge stm id)
    55   (* pop_frame          ≝ *) (λ_.λ_.λ_.λ_.pop_ra …).
     59  (* pop_frame          ≝ *) (λ_.λ_.λ_.λ_.ertl_pop_frame).
     60 
    5661definition ERTLptr_semantics ≝
    57   make_sem_graph_params ERTLptr ERTLptr_sem_uns.
     62  mk_sem_graph_params ERTLptr ERTLptr_sem_uns.
  • src/LIN/LIN_semantics.ma

    r2601 r2783  
    33
    44definition LIN_semantics : sem_params ≝
    5   make_sem_lin_params LIN LTL_LIN_semantics.
     5  mk_sem_lin_params LIN LTL_LIN_semantics.
  • src/LIN/joint_LTL_LIN.ma

    r2645 r2783  
    2020].
    2121
    22 definition LTL_LIN : unserialized_params ≝ mk_unserialized_params
     22definition LTL_LIN_uns : unserialized_params ≝ mk_unserialized_params
    2323    (* acc_a_reg ≝ *) unit
    2424    (* acc_b_reg ≝ *) unit
     
    3838    (* paramsT ≝ *) unit.
    3939
     40definition LTL_LIN_functs : get_pseudo_reg_functs LTL_LIN_uns ≝
     41mk_get_pseudo_reg_functs ?
     42(* acc_a_regs *) (λ_.[ ])
     43(* acc_b_regs *) (λ_.[ ])
     44(* acc_a_args *) (λ_.[ ])
     45(* acc_b_args *) (λ_.[ ])
     46(* dpl_regs *) (λ_.[ ])
     47(* dph_regs *) (λ_.[ ])
     48(* dpl_args *) (λ_.[ ])
     49(* dph_args *) (λ_.[ ])
     50(* snd_args *) (λ_.[ ])
     51(* pair_move_regs *) (λ_.[ ])
     52(* f_call_args *) (λ_.[ ])
     53(* f_call_dest *) (λ_.[ ])
     54(* ext_seq_regs *) (λ_.[ ])
     55(* params_regs *) (λ_.[ ]).
     56
     57definition LTL_LIN ≝  mk_uns_params LTL_LIN_uns LTL_LIN_functs.
     58
    4059interpretation "move from acc" 'mov a b = (MOVE ?? (from_acc a b)).
    4160interpretation "move to acc" 'mov a b = (MOVE ?? (to_acc a b)).
  • src/LIN/joint_LTL_LIN_semantics.ma

    r2645 r2783  
    3838axiom eval_ltl_lin_seq : ltl_lin_seq → state LTL_LIN_state → IO io_out io_in (state LTL_LIN_state).
    3939
     40definition LTL_LIN_save_frame :
     41call_kind → unit → state_pc LTL_LIN_state → res(state LTL_LIN_state) ≝
     42λk.λ_.λst. match k with
     43[ PTR ⇒ return (st_no_pc … st)
     44| ID ⇒ push_ra … st (pc … st)
     45].
     46
    4047definition LTL_LIN_semantics ≝
    4148  λF.mk_sem_unserialized_params LTL_LIN F
     
    5764(*  (* fetch_ra           ≝ *) (load_ra …)
    5865  (* allocate_local     ≝ *) (λabs.match abs in void with [ ])
    59 *)  (* save_frame         ≝ *) ?(*(λp.λ_.λst.save_ra … st p)*)
     66*)  (* save_frame         ≝ *) LTL_LIN_save_frame
    6067  (* setup_call         ≝ *) (λ_.λ_.λ_.λst.return st)
    6168  (* fetch_external_args≝ *) ?(*ltl_lin_fetch_external_args*)
     
    6875(*  (* eval_ext_tailcall  ≝ *) ?(*(λ_.λ_.λabs.match abs in void with [ ])*)
    6976  (* eval_ext_call      ≝ *) (λ_.λ_.λabs.match abs in void with [ ])
    70 *)  (* pop_frame          ≝ *) ?(*(λ_.λ_.λ_.λst.return st)*)
     77*)  (* pop_frame          ≝ *) ((λ_.λ_.λ_.λ_.λst.pop_ra … st))
    7178(*  (* post_op2           ≝ *) (λ_.λ_.λ_.λ_.λ_.λ_.λst.st)*).
     79cases daemon
     80qed.
  • src/LTL/LTL_semantics.ma

    r2601 r2783  
    33
    44definition LTL_semantics : sem_params ≝
    5   make_sem_graph_params LTL LTL_LIN_semantics.
     5  mk_sem_graph_params LTL LTL_LIN_semantics.
  • src/RTL/RTL.ma

    r2681 r2783  
    2222    (* paramsT ≝ *) (list register).
    2323
    24 definition RTL ≝ mk_graph_params RTL_uns.
     24definition RTL_functs ≝ mk_get_pseudo_reg_functs RTL_uns
     25(* acc_a_regs *) (λr.[r])
     26(* acc_b_regs *) (λr.[r])
     27(* acc_a_args *) (λa. match a with [Reg r ⇒ [r] |Imm _ ⇒ [ ]])
     28(* acc_b_args *) (λa. match a with [Reg r ⇒ [r] |Imm _ ⇒ [ ]])
     29(* dpl_regs *) (λr.[r])
     30(* dph_regs *) (λr.[r])
     31(* dpl_args *) (λa. match a with [Reg r ⇒ [r] |Imm _ ⇒ [ ]])
     32(* dph_args *) (λa. match a with [Reg r ⇒ [r] |Imm _ ⇒ [ ]])
     33(* snd_args *) (λa. match a with [Reg r ⇒ [r] |Imm _ ⇒ [ ]])
     34(* pair_move_regs *) (λx.[\fst x] @ (match \snd x with [Reg r ⇒ [r] |Imm _ ⇒ [ ]]))
     35(* f_call_args *) (λl.foldl ?? (λl1.λa.l1@(match a with [Reg r ⇒ [r] |Imm _ ⇒ [ ]])) [ ] l)
     36(* f_call_dest *) (λx.x)
     37(* ext_seq_regs *) (λext.match ext with [rtl_stack_address r1 r2 ⇒ [r1;r2]])
     38(* params_regs *) (λx.x).
     39
     40definition RTL ≝ mk_graph_params (mk_uns_params RTL_uns RTL_functs).
    2541definition rtl_program ≝ joint_program RTL.
    2642
  • src/common/ExtraMonads.ma

    r2590 r2783  
    305305#y * #y_spec #v_spec %{y} % // >y_spec %
    306306qed.
     307
     308lemma res_preserve_error11 : ∀X,Y,F,e,n. (∃e'.n = Error … e') →
     309res_preserve1 X Y F n (Error … e).
     310#X #Y #F #e #n * #e' #n_spec >n_spec @res_preserve_error1
     311qed.
  • src/common/GenMem.ma

    r2608 r2783  
    207207    let blocks ≝ update_block … b content (blocks … m) in
    208208     mk_mem … blocks (nextblock … m) (nextblock_pos … m)).
     209     
     210(* Axiom of extensional equality for the memory *)     
     211axiom mem_ext_eq :
     212  ∀m1,m2 : mem.
     213  (∀b.let bc1 ≝ blocks m1 b in
     214      let bc2 ≝ blocks m2 b in
     215      low bc1 = low bc2 ∧ high bc1 = high bc2 ∧
     216      ∀z.contents bc1 z = contents bc2 z) →
     217  nextblock m1 = nextblock m2 → m1 = m2.     
     218
  • src/common/extraGlobalenvs.ma

    r2608 r2783  
    240240qed.
    241241
     242lemma symbol_for_block_match:
     243    ∀M:matching.∀initV,initW.
     244     (∀v,w. match_var_entry M v w →
     245      size_init_data_list (initV (\snd v)) = size_init_data_list (initW (\snd w))) →
     246    ∀p: program (m_A M) (m_V M). ∀p': program (m_B M) (m_W M).
     247    ∀MATCH:match_program … M p p'.
     248    ∀b: block.
     249    symbol_for_block … (globalenv … initW p') b =
     250    symbol_for_block … (globalenv … initV p) b.
     251* #A #B #V #W #match_fn #match_var #initV #initW #H
     252#p #p' * #Mvars #Mfn #Mmain
     253#b
     254whd in match symbol_for_block; normalize nodelta
     255whd in match globalenv in ⊢ (???%); normalize nodelta
     256whd in match (globalenv_allocmem ????);
     257change with (add_globals ?????) in match (foldl ?????);
     258>(proj1 … (add_globals_match … initW … Mvars))
     259[ % |*:]
     260[ * #idr #v * #idr' #w #MVE %
     261  [ inversion MVE
     262    #H1 #H2 #H3 #H4 #H5 #H6 #H7 #H8 destruct %
     263  | @(H … MVE)
     264  ]
     265| @(matching_fns_get_same_blocks … Mfn)
     266  #f #g @match_funct_entry_id
     267]
     268qed.
     269
     270lemma symbol_for_block_transf :
     271 ∀A,B,V,init.∀prog_in : program A V.
     272 ∀trans : ∀vars.A vars → B vars.
     273 let prog_out ≝ transform_program … prog_in trans in
     274 ∀bl.
     275 symbol_for_block … (globalenv … init prog_out) bl =
     276 symbol_for_block … (globalenv … init prog_in) bl.
     277#A #B #V #iV #p #tf @(symbol_for_block_match … (transform_program_match … tf ?))
     278#v0 #w0 * //
     279qed.
     280
     281lemma vars_irrelevant_to_find_funct_ptr_inv :
     282  ∀F,G,V,W.
     283  ∀P:F → G → Prop.
     284  ∀init,init',b,vars,vars',ge,ge',m,m',f.
     285  (find_funct_ptr G ge' b = Some ? f → ∃f'. find_funct_ptr F ge b = Some ? f' ∧ P f' f) →
     286  symbols F ge = symbols G ge' →
     287  nextblock m = nextblock m' →
     288  All2 … (λx,y. \fst x = \fst y) vars vars' →
     289  find_funct_ptr G (\fst (add_globals G W init' 〈ge',m'〉 vars')) b = Some ? f →
     290  ∃f'.find_funct_ptr F (\fst (add_globals F V init 〈ge,m〉 vars)) b = Some ? f' ∧ P f' f.
     291#F #G #V #W #P #init #init'
     292* * [ 2,3(*,5,6*): #blk ] [ 2: | 1,3: #vars #vars' #ge #ge' #m #m' #f #H1 #H2 #H3 #H4 #H5 whd in H5:(??%?); destruct ]
     293#vars elim vars
     294[ * [ #ge #ge' #m #m' #f #H #_ #_ #_ @H
     295    | #x #tl #ge #ge' #m #m' #f #_ #_ #_ *
     296    ]
     297| * * #id #r #v #tl #IH *
     298  [ #ge #ge' #m #m' #f #_ #_ #_ *
     299  | * * #id' #r' #v' #tl'
     300    #ge #ge' #m #m' #f #FFP1 #Esym #Enext * #E destruct #MATCH
     301    whd in match (add_globals ?????); whd in match (add_globals F ????);
     302    whd in ⊢ (??(??(???(????%?))?)? → ??(λ_.?(??(??(???(????%?))?)?)?));
     303    @(alloc_pair … Enext) #m1 #m2 #b #Enext'
     304    whd in ⊢ (??(??(???(????%?))?)? → ??(λ_.?(??(??(???(????%?))?)?)?));
     305    #FFP
     306    @(IH … MATCH FFP)
     307    [ whd in ⊢ (??%? → ??(λ_.?(??%?)?));
     308      whd in ⊢ (??(???%)? → ??(λ_.?(??(???%)?)?));
     309      >Esym
     310      cases ( lookup SymbolTag block (symbols G ge') id')
     311      [ @FFP1
     312      | * * (* * *) try @FFP1 #p try @FFP1
     313        normalize
     314        cases (decidable_eq_pos blk p)
     315        [ #E destruct >lookup_opt_pm_set_hit #E destruct
     316        | #NE >(lookup_opt_pm_set_miss … NE) >(lookup_opt_pm_set_miss … NE)
     317          @FFP1
     318        ]
     319      ]
     320    | whd in match (add_symbol ????); whd in match (drop_fn ???);
     321      whd in match (add_symbol ????); whd in match (drop_fn ???);
     322      >Esym %
     323    | assumption
     324    ]
     325  ]
     326] qed.
     327
     328lemma All2_swap : ∀ A,B,P,l1,l2. All2 A B P l1 l2 →
     329All2 B A (λx,y.P y x) l2 l1.
     330#A #B #P #l1 elim l1 [* [ #_ @I] #b #tlb *]
     331#a #tl_a #IH * [ *] #b #tl_b * #H #H1 whd % [assumption]
     332@IH assumption
     333qed.
     334
     335lemma find_funct_ptr_All2_inv : ∀A,B,V,W,b,p.
     336∀initV,initW,p',P.∀f : B (prog_var_names B W p').
     337  All2 ?? (λx,y. \fst x = \fst y ∧ P (\snd x) (\snd y)) (prog_funct ?? p) (prog_funct … p') →
     338  All2 … (λx,y. \fst x = \fst y) (prog_vars ?? p) (prog_vars ?? p') →
     339  find_funct_ptr … (globalenv B W initW p') b = Some ? f →
     340  ∃f'. find_funct_ptr … (globalenv A V initV p) b = Some ? f' ∧ P f' f.
     341#A #B #V #W #b * #vars #fns #main #initV #initW * #vars' #fns' #main' #P #f
     342#Mfns
     343cases b * (* * *) [ 2,3 (*,5,6*) (*,8,9,11,12,14,15,17,18*): #bp ]
     344[ 2: (*12:*) | *: #_ #F whd in F:(??%?); destruct ]
     345whd in match (globalenv ????); whd in match (globalenv_allocmem ????);
     346whd in match (globalenv ????); whd in match (globalenv_allocmem ????);
     347@vars_irrelevant_to_find_funct_ptr_inv
     348[ letin varnames ≝ (map ??? vars)
     349  generalize in match fns in Mfns ⊢ %;
     350  elim fns'
     351  [ #fns #Mfns whd in ⊢ (??%? → ?); #E destruct
     352  | * #id #fn #tl #IH * * #id' #fn' #tl' * * #E #Phd destruct #Mtl
     353    whd in ⊢ (??%? → ?);
     354    whd in match (functions ??);
     355    change with (add_functs ???) in match (foldr ?????);
     356    cases (ge_add_functs ?? tl tl' ?) [2: @(All2_mp … (All2_swap … Mtl)) * #idA #a * #idB #b * // ]
     357    #SYMS #NEXT
     358    cases (decidable_eq_pos bp (nextfunction … (add_functs ? (empty ?) tl)))
     359    [ #E destruct >lookup_opt_insert_hit #E destruct
     360      %{fn'} % // whd in ⊢ (??%?);
     361      whd in match (functions ??);
     362      change with (add_functs ???) in match (foldr ???? tl');
     363      >NEXT >lookup_opt_insert_hit @refl
     364    | #NE >lookup_opt_insert_miss //
     365      #FFP cases (IH tl' Mtl ?)
     366      [ #fn'' * #FFP' #P' %{fn''} %
     367        [ whd in ⊢ (??%?);
     368          >lookup_opt_insert_miss [2: <NEXT // ]
     369          lapply (lookup_drop_fn_different ????? FFP)
     370          >SYMS
     371          #L >lookup_drop_fn_irrelevant // @FFP'
     372        | @P'
     373        ]
     374      | @(drop_fn_lfn … FFP)
     375      ]
     376    ]
     377  ]
     378| cases (ge_add_functs ?? fns fns' ?) [2: @(All2_mp … Mfns) * #idA #a * #idB #b * // ]
     379  #S #_ @S
     380| @refl
     381] qed.
     382
     383lemma find_funct_ptr_match_inv:
     384    ∀M:matching.∀initV,initW.
     385    ∀p: program (m_A M) (m_V M). ∀p': program (m_B M) (m_W M).
     386    ∀MATCH:match_program … M p p'.
     387    ∀b: block. ∀tf: m_B M (prog_var_names … p').
     388    find_funct_ptr … (globalenv … initW p') b = Some ? tf →
     389    ∃f : m_A M (prog_var_names … p).
     390    find_funct_ptr … (globalenv … initV p) b = Some ? f ∧
     391     match_fundef M ? f (tf⌈m_B M ? ↦ m_B M (prog_var_names … p)⌉).
     392[ 2: >(matching_vars … (mp_vars … MATCH)) % ]
     393* #A #B #V #W #match_fn #match_var #initV #initW
     394#p #p' * #Mvars #Mfn #Mmain
     395#b #f #FFP @(find_funct_ptr_All2_inv A B V W ????????? FFP)
     396[ lapply (matching_vars … (mk_matching A B V W match_fn match_var) … Mvars)
     397  #E
     398  @(All2_mp … Mfn)
     399  * #id #f * #id' #f'
     400  <E in f' ⊢ %; #f' -Mmain -b -Mfn -Mvars -initV -initW -E
     401  normalize #H @(match_funct_entry_inv … H)
     402  #vs #id1 #f1 #f2 #M % //
     403| @(All2_mp … Mvars)
     404  * #x #x' * #y #y' #M inversion M #id #r #v1 #v2 #M' #E1 #E2 #_ destruct //
     405qed.
     406
     407lemma find_funct_ptr_transf_none :
     408  ∀A,B,V,iV. ∀p: program A V. ∀transf: (∀vs. A vs → B vs).
     409    ∀b: block.
     410    find_funct_ptr ? (globalenv … iV p) b = None ? →
     411    find_funct_ptr ? (globalenv … iV (transform_program … p transf)) b = None ?.
     412#A #B #V #iV #p #transf #b #EQf inversion(find_funct_ptr ???) [#_ %]
     413#tf #EQtf
     414cases (find_funct_ptr_match_inv … (transform_program_match … transf ?) … EQtf)
     415[2: @iV] #f * #EQf' #_ >EQf in EQf'; #ABS destruct
     416qed.
     417
     418lemma find_funct_ptr_transf_commute :
     419∀A,B,V,iV. ∀p: program A V. ∀transf: (∀vs. A vs → B vs).
     420    ∀b: block.
     421 find_funct_ptr ? (globalenv … iV (transform_program … p transf)) b =
     422 ! f ← find_funct_ptr ? (globalenv … iV p) b;
     423 return transf … f.
     424#A #B #V #iV #p #transf #bl inversion(find_funct_ptr ? (globalenv … iV p) bl)
     425[ #EQ >(find_funct_ptr_transf_none … transf … EQ) %]
     426#f #EQ >(find_funct_ptr_transf … transf … EQ) %
     427qed.
     428   
     429   
     430
     431
     432
     433
  • src/joint/Joint.ma

    r2774 r2783  
    9191 ; paramsT : Type[0]
    9292 }.
     93 
     94record get_pseudo_reg_functs (p : unserialized_params) : Type[0] ≝
     95{ acc_a_regs : acc_a_reg p → list register
     96; acc_b_regs : acc_b_reg p → list register
     97; acc_a_args : acc_a_arg p → list register
     98; acc_b_args : acc_b_arg p → list register
     99; dpl_regs : dpl_reg p → list register
     100; dph_regs : dph_reg p → list register
     101; dpl_args : dpl_arg p → list register
     102; dph_args : dph_arg p → list register
     103; snd_args : snd_arg p → list register
     104; pair_move_regs : pair_move p → list register
     105; f_call_args : call_args p → list register
     106; f_call_dest : call_dest p → list register
     107; ext_seq_regs : ext_seq p → list register
     108; params_regs : paramsT p → list register
     109}.
     110
     111record uns_params : Type[1] ≝
     112{ u_pars :> unserialized_params
     113; functs : get_pseudo_reg_functs u_pars
     114}.
    93115
    94116inductive joint_seq (p:unserialized_params) (globals: list ident): Type[0] ≝
     
    108130  | STORE: dpl_arg p → dph_arg p → acc_a_arg p → joint_seq p globals
    109131  | extension_seq : ext_seq p → joint_seq p globals.
     132 
     133definition get_used_registers_from_seq : ∀p : unserialized_params.∀globals.
     134get_pseudo_reg_functs p → joint_seq p globals → list register ≝
     135λp,globals,functs,seq.
     136match seq with
     137[ COMMENT _ ⇒ [ ]
     138| MOVE pm ⇒ pair_move_regs … functs pm
     139| POP r ⇒ acc_a_regs … functs r
     140| PUSH r ⇒ acc_a_args … functs r
     141| ADDRESS i prf r1 r2 ⇒ (dpl_regs … functs r1) @ (dph_regs … functs r2)
     142| OPACCS o r1 r2 r3 r4 ⇒ (acc_a_regs … functs r1) @ (acc_b_regs … functs r2)
     143       @ (acc_a_args … functs r3) @ (acc_b_args … functs r4)
     144| OP1 o r1 r2 ⇒ (acc_a_regs … functs r1) @ (acc_a_regs … functs r2)
     145| OP2 o r1 r2 r3 ⇒ (acc_a_regs … functs r1) @ (acc_a_args … functs r2) @
     146         (snd_args … functs r3)
     147| CLEAR_CARRY ⇒ [ ]
     148| SET_CARRY ⇒ [ ]
     149| LOAD r1 r2 r3 ⇒ (acc_a_regs … functs r1) @ (dpl_args … functs r2) @
     150                  (dph_args … functs r3)
     151| STORE r1 r2 r3 ⇒ (dpl_args … functs r1) @ (dph_args … functs r2) @
     152                    (acc_a_args … functs r3)
     153| extension_seq ext ⇒ ext_seq_regs … functs ext
     154].
    110155
    111156definition NOOP ≝ λp,globals.COMMENT p globals EmptyString.
     
    139184  | COND: acc_a_reg p → label → joint_step p globals
    140185  | step_seq : joint_seq p globals → joint_step p globals.
     186 
     187definition get_used_registers_from_step : ∀p : unserialized_params.∀globals.
     188get_pseudo_reg_functs p → joint_step p globals → list register ≝
     189λp,globals,functs,step.
     190match step with
     191[ COST_LABEL c ⇒ [ ]
     192| CALL id args dest ⇒ (f_call_args … functs args) @ (f_call_dest … functs dest)
     193| COND r lbl ⇒  acc_a_regs … functs r
     194| step_seq s ⇒ get_used_registers_from_seq … functs s
     195].
    141196
    142197coercion seq_to_step : ∀p,globals.∀s : joint_seq p globals.joint_step p globals ≝
     
    160215
    161216record stmt_params : Type[1] ≝
    162   { uns_pars :> unserialized_params
     217  { uns_pars :> uns_params
    163218  ; succ : Type[0]
    164219  ; succ_label : succ → option label
     
    257312     | None ⇒ [ ]
    258313     ]) @ stmt_explicit_labels … stmt.
     314     
     315definition stmt_registers : ∀p : stmt_params.∀globals.
     316joint_statement p globals → list register ≝
     317λp,globals,stmt.
     318match stmt with
     319[ sequential c _ ⇒ get_used_registers_from_step … (functs … p) c
     320| final c ⇒
     321   match c with [ TAILCALL _ _ r ⇒ f_call_args … (functs … p) r | _ ⇒ [ ] ]
     322| FCOND _ r _ _ ⇒ acc_a_regs … (functs … p) r
     323].
    259324
    260325definition stmt_forall_labels ≝
    261326  λp, globals.λ P : label → Prop.λs : joint_statement p globals.
    262327  All … P (stmt_labels … s).
     328 
    263329
    264330lemma stmt_forall_labels_explicit : ∀p,globals,P.∀s : joint_statement p globals.
     
    290356
    291357record lin_params : Type[1] ≝
    292   { l_u_pars : unserialized_params }.
     358  { l_u_pars : uns_params }.
    293359 
    294360lemma index_of_label_length : ∀tag,A,lbl,l.occurs_exactly_once ?? lbl l → lt (index_of_label tag A lbl l) (|l|).
     
    361427
    362428record graph_params : Type[1] ≝
    363   { g_u_pars : unserialized_params }.
     429  { g_u_pars : uns_params }.
    364430
    365431(* One common instantiation of params via Graphs of joint_statements
     
    415481  joint_if_exit : Σpt.bool_to_Prop (code_has_point … joint_if_code pt) *)
    416482}.
     483
     484definition regs_in_universe : ∀p,globals.
     485codeT p globals → universe RegisterTag → Prop ≝
     486λp,globals,c,u.∀pt,stmt.stmt_at p globals c pt = return stmt →
     487All ? (λreg.fresh_for_univ … reg u) (stmt_registers … stmt).
    417488
    418489definition code_in_universe : ∀p,globals.
     
    459530; code_is_in_universe :
    460531  code_in_universe … (joint_if_code … def) (joint_if_luniverse … def)
     532; regs_are_in_univers :
     533  regs_in_universe … (joint_if_code … def) (joint_if_runiverse … def)
    461534}.
    462535 
  • src/joint/Traces.ma

    r2757 r2783  
    8282  (* use exit_pc as ra and call_dest_for_main as dest *)
    8383  let st0' ≝ mk_state_pc … (set_sp … spp st0) exit_pc exit_pc in
    84   ! st0_no_pc ← save_frame ?? sem_globals ID (call_dest_for_main … pars) (prog_main … p) st0' ;
     84  ! st0_no_pc ← save_frame ?? sem_globals ID (call_dest_for_main … pars) st0' ;
    8585  let st0'' ≝ set_no_pc … st0_no_pc st0' in
    8686  ! bl ← block_of_call … ge (inl … main) st0'';
  • src/joint/joint_semantics.ma

    r2688 r2783  
    5454
    5555record state (semp: sem_state_params): Type[0] ≝
    56  { st_frms: framesT semp
     56 { st_frms: option(framesT semp)
    5757 ; istack : internal_stack
    5858 ; carry: bebit
     
    103103
    104104definition set_frms: ∀p:sem_state_params. framesT p → state p → state p ≝
    105  λp,frms,st. mk_state … frms (istack … st) (carry … st) (regs … st) (m … st).
     105 λp,frms,st. mk_state … (Some ? (frms)) (istack … st) (carry … st) (regs … st) (m … st).
    106106
    107107(*
     
    184184  (* Paolo: save_frame separated from call_setup to factorize tailcall code *)
    185185  (* ; allocate_locals_ : localsT uns_pars → regsT st_pars → regsT st_pars *)
    186   ; save_frame: call_kind → call_dest uns_pars → ident → state_pc st_pars → res (state st_pars)
     186  ; save_frame: call_kind → call_dest uns_pars → state_pc st_pars → res (state st_pars)
    187187   (*CSC: setup_call returns a res only because we can call a function with the wrong number and
    188188     type of arguments. To be fixed using a dependent type *)
     
    528528match fd with
    529529[ Internal ifd ⇒
    530   let ident ≝ ? in
    531   ! st' ← save_frame … (kind_of_call … f) dest ident st ;
     530  ! st' ← save_frame … (kind_of_call … f) dest st ;
    532531  ! st'' ← eval_internal_call p globals ge i ifd args st' ;
    533532  let pc ≝ pc_of_point p bl (joint_if_entry … ifd) in
     
    536535  ! st' ← eval_external_call … efd args dest st ;
    537536  return mk_state_pc … st' (succ_pc p (pc … st) nxt) (last_pop … st)
    538 ]. cases daemon qed. (*TODO*)
     537].
    539538
    540539definition eval_statement_no_pc :
  • src/joint/semanticsUtils.ma

    r2708 r2783  
    5050}.
    5151
    52 definition reg_store ≝ λreg,v,locals. update RegisterTag beval locals reg v.
     52definition reg_store ≝ λreg,v,locals. OK ? (add RegisterTag beval locals reg v).
    5353
    5454definition reg_retrieve : register_env beval → register → res beval ≝
     
    6969
    7070record sem_graph_params : Type[1] ≝
    71 { sgp_pars : unserialized_params
     71{ sgp_pars : uns_params
    7272; sgp_sup : ∀F.sem_unserialized_params sgp_pars F
    7373}.
     74
    7475
    7576definition sem_graph_params_to_graph_params :
     
    107108
    108109record sem_lin_params : Type[1] ≝
    109 { slp_pars : unserialized_params
     110{ slp_pars : uns_params
    110111; slp_sup : ∀F.sem_unserialized_params slp_pars F
    111112}.
Note: See TracChangeset for help on using the changeset viewer.