Changeset 1311


Ignore:
Timestamp:
Oct 6, 2011, 6:45:54 PM (8 years ago)
Author:
campbell
Message:

Merge trunk to invariants branch, sorting out the handling of temporaries
in Clight/toCminor.

Location:
Deliverables/D3.3/id-lookup-branch
Files:
8 deleted
51 edited
19 copied

Legend:

Unmodified
Added
Removed
  • Deliverables/D3.3/id-lookup-branch

  • Deliverables/D3.3/id-lookup-branch/ASM

  • Deliverables/D3.3/id-lookup-branch/ASM/Arithmetic.ma

    r961 r1311  
    319319alias symbol "greater_than_or_equal" (instance 1) = "nat greater than or equal prop".
    320320
     321definition max_u ≝ λn,a,b. if lt_u n a b then b else a.
     322definition min_u ≝ λn,a,b. if lt_u n a b then a else b.
     323definition max_s ≝ λn,a,b. if lt_s n a b then b else a.
     324definition min_s ≝ λn,a,b. if lt_s n a b then a else b.
     325
    321326definition bitvector_of_bool:
    322327      ∀n: nat. ∀b: bool. BitVector (S n) ≝
  • Deliverables/D3.3/id-lookup-branch/ASM/Util.ma

    r1197 r1311  
    4040definition gtb ≝
    4141  λm, n: nat.
    42     leb n m.
     42    ltb n m.
    4343
    4444(* dpm: unless I'm being stupid, this isn't defined in the stdlib? *)
  • Deliverables/D3.3/id-lookup-branch/CHANGES

    r1153 r1311  
    7777  of intermediate languages from ERTL on, we need to recover the arguments
    7878  for the function not only from the registers, but also from the stack.
     79
     8008/09/2011:
     81  The Clight cast simplification algorithm is quite different to the prototype's:
     82  it only needs to do a simple pattern match per recursion and copes with deeper
     83  arithmetic expressions such as (char)((int)x + (int)y + (int)z).
  • Deliverables/D3.3/id-lookup-branch/Clight/Cexec.ma

    r1153 r1311  
    499499axiom MainMissing : String.
    500500
    501 let rec make_initial_state (p:clight_program) : res (genv × state) ≝
    502   do ge ← globalenv Genv ?? (fst ??) p;
     501definition make_global : clight_program → genv ≝
     502λp. globalenv Genv ?? (fst ??) p.
     503
     504let rec make_initial_state (p:clight_program) : res state ≝
     505  let ge ≝ make_global p in
    503506  do m0 ← init_mem Genv ?? (fst ??) p;
    504507  do b ← opt_to_res ? (msg MainMissing) (find_symbol ? ? ge (prog_main ?? p));
    505508  do f ← opt_to_res ? (msg MainMissing) (find_funct_ptr ? ? ge b);
    506   OK ? 〈ge,Callstate f (nil ?) Kstop m0〉.
     509  OK ? (Callstate f (nil ?) Kstop m0).
    507510
    508511let rec is_final (s:state) : option int ≝
     
    558561λs.match s with [ State f s k e m ⇒ m | Callstate f a k m ⇒ m | Returnstate r k m ⇒ m ].
    559562
    560 definition clight_exec : execstep io_out io_in ≝
    561   mk_execstep … is_final mem_of_state exec_step.
     563definition clight_exec : trans_system io_out io_in ≝
     564  mk_trans_system ?? genv (λ_.state) (λ_.is_final) exec_step.
    562565
    563566definition clight_fullexec : fullexec io_out io_in ≝
    564   mk_fullexec ?? clight_exec ? make_initial_state.
     567  mk_fullexec ??? clight_exec make_global make_initial_state.
  • Deliverables/D3.3/id-lookup-branch/Clight/CexecComplete.ma

    r1058 r1311  
    8181
    8282theorem the_initial_state:
    83   ∀p,s. initial_state p s → ∃ge. yields ? (make_initial_state p) 〈ge,s〉.
    84 #p #s cases p; #fns #main #globs #H
     83  ∀p,s. initial_state p s → yields ? (make_initial_state p) s.
     84#p #s cases p; #globs #fns #main #H
    8585inversion H;
    86 #b #f #ge #m #e1 #e2 #e3 #e4 #e5 %{ge}
    87 whd in ⊢ (??%?);
    88 >e1
     86#b #f #ge #m #e1 #e2 #e3 #e4 #e5
    8987whd in ⊢ (??%?);
    9088>e2
    9189whd in ⊢ (??%?);
     90change in e1:(??%?) with (make_global (mk_program ?? globs fns main))
     91>e1
    9292>e3
    9393whd in ⊢ (??%?);
  • Deliverables/D3.3/id-lookup-branch/Clight/CexecEquiv.ma

    r961 r1311  
    1313
    1414coinductive single_exec_of : execution state io_out io_in → s_execution → Prop ≝
    15 | seo_stop : ∀tr,r,m. single_exec_of (e_stop ??? tr r m) (se_stop tr r m)
     15| seo_stop : ∀tr,r,s. single_exec_of (e_stop ??? tr r s) (se_stop tr r (mem_of_state s))
    1616| seo_step : ∀tr,s,e,se.
    1717    single_exec_of e se →
     
    5959] qed.
    6060
    61 lemma is_final_elim': ∀s.∀P:option int → Type[0].
     61lemma is_final_elim': ∀ge,s.∀P:option int → Type[0].
    6262 (∀r. final_state s r → P (Some ? r)) →
    6363 ((¬∃r.final_state s r) → P (None ?)) →
    64 P (is_final io_out io_in clight_fullexec s).
    65 @is_final_elim qed.
     64P (is_final io_out io_in clight_fullexec ge s).
     65#ge @is_final_elim qed.
    6666
    6767lemma exec_e_step: ∀ge,x,tr,s,e.
     
    300300
    301301
    302 lemma e_stop_inv: ∀ge,x,tr,r,m.
    303   exec_inf_aux ?? clight_exec ge x = e_stop ??? tr r m
    304   x = Value ??? 〈tr,Returnstate (Vint I32 r) Kstop m〉.
    305 #ge #x #tr #r #m
     302lemma e_stop_inv: ∀ge,x,tr,r,s.
     303  exec_inf_aux ?? clight_exec ge x = e_stop ??? tr r s
     304  x = Value ??? 〈tr,Returnstate (Vint I32 r) Kstop (mem_of_state s)〉.
     305#ge #x #tr #r #s
    306306>(exec_inf_aux_unfold …) cases x;
    307307[ #o #k #EXEC whd in EXEC:(??%?); destruct;
     
    684684  single_exec_of e1 e2 →
    685685  match e1 with
    686   [ e_stop tr r m ⇒ match e2 with [ se_stop tr' r' m' ⇒ tr = tr' ∧ r = r' ∧ m = m' | _ ⇒ False ]
     686  [ e_stop tr r s ⇒ match e2 with [ se_stop tr' r' m' ⇒ tr = tr' ∧ r = r' ∧ mem_of_state s = m' | _ ⇒ False ]
    687687  | e_step tr s e1' ⇒ match e2 with [ se_step tr' s' e2' ⇒ tr = tr' ∧ s = s' ∧ single_exec_of e1' e2' | _ ⇒ False ]
    688688  | e_wrong _ ⇒ match e2 with [ se_wrong _ ⇒ True | _ ⇒ False ]
     
    691691#e01 #e02 #H
    692692cases H;
    693 [ #tr #r #m whd; % [ % ] //
     693[ #tr #r #s whd; % [ % ] //
    694694| #tr #s #e1' #e2' #H' whd; % [ % ] //
    695695| #msg whd; //
     
    10211021whd in ⊢ (? → ? → ?(match % with [_ ⇒ ? | _ ⇒ ?])? → ?)
    10221022cases (make_initial_state p)
    1023 [ #gs cases gs; #ge #s #INITIAL' #INITIAL whd in INITIAL ⊢ (?%? → ?);
    1024     cases INITIAL; #Ege #INITIAL''
     1023[ #s #INITIAL' #INITIAL whd in INITIAL ⊢ (?%? → ?);
    10251024    >exec_inf_aux_unfold
    10261025    whd in ⊢ (?%? → ?)
    10271026    @is_final_elim'
    10281027    [ #r #F @False_ind
    1029         @(absurd ?? (initial_state_not_final … INITIAL''))
     1028        @(absurd ?? (initial_state_not_final … INITIAL))
    10301029        %{r} @F
    10311030    | #NOTFINAL whd in ⊢ (?%? → ?); cases e;
     
    10331032        cases (se_inv … EXEC0); *; #E1 #E2 <E1 <E2 #EXEC'
    10341033    lapply (behavior_of_execution ??
    1035               (execution_characterisation_complete classic constructive_indefinite_description ge s ? EXEC'));
     1034              (execution_characterisation_complete classic constructive_indefinite_description ? s ? EXEC'));
    10361035        *; #b #MATCHES %{b} % [ @MATCHES ]
    1037         #ge' >Ege #Ege' >(?:ge' = ge) [ 2: destruct (Ege') skip (INITIAL Ege EXEC0 EXEC'); // ]
     1036        #ge #Ege
    10381037        inversion MATCHES;
    10391038        [ #s0 #e1 #tr1 #r #m #TERM #EXEC #BEHAVES <EXEC in TERM
     
    10421041            >E1 in TERM #TERM
    10431042            @(program_terminates (mk_transrel … step) ?? ge s)
    1044             [ 2: @INITIAL''
    1045             | 3: @(terminates_sound … TERM EXEC')
     1043            [ 2: @INITIAL
     1044            | 3: <Ege @(terminates_sound … TERM EXEC')
    10461045            | skip
    10471046            | //;
     
    10551054            #E7 <E7 in INITSTEPS #INITSTEPS
    10561055            cases (several_steps … INITSTEPS EXEC'); #INITSTAR #EXECDIV
    1057             @(program_diverges (mk_transrel … step) ?? ge s … INITIAL'' INITSTAR)
    1058             @(silent_sound … DIVERGING EXECDIV)
     1056            @(program_diverges (mk_transrel … step) ?? ge s … INITIAL)
     1057            [ 2: <Ege @INITSTAR
     1058            | 3: <Ege @(silent_sound … DIVERGING EXECDIV)
     1059            ]
    10591060        | #s0 #e #tr #REACTS #EXEC #E2 <EXEC in REACTS #REACTS
    10601061            lapply (exec_state_reacts … REACTS);
     
    10641065            cut (e0 = e''); [ destruct (E6) skip (MATCHES EXEC0 EXEC'); // ]
    10651066            #E7 <E7 in REACTING #REACTING
    1066             @(program_reacts (mk_transrel … step) ?? ge s … INITIAL'')
    1067             @(reacts_sound … REACTING EXEC')
     1067            @(program_reacts (mk_transrel … step) ?? ge s … INITIAL)
     1068            <Ege @(reacts_sound … REACTING EXEC')
    10681069        | #e #s1 #s2 #tr #WRONG #EXEC #E2 <EXEC in WRONG #WRONG
    10691070            lapply (exec_state_wrong … WRONG);
     
    10741075            #E8 <E8 in GOESWRONG #GOESWRONG
    10751076            elim (wrong_sound … WRONG EXEC' NOTFINAL); *; #STAR #STOP #FINAL
    1076             @(program_goes_wrong (mk_transrel … step) ?? ge s … INITIAL'' STAR STOP)
     1077            <Ege
     1078            @(program_goes_wrong (mk_transrel … step) ?? ? s … INITIAL STAR STOP)
    10771079            #r % #F @(absurd ?? FINAL) %{r} @F
    10781080        | #msg #E destruct (E);
  • Deliverables/D3.3/id-lookup-branch/Clight/CexecSound.ma

    r1153 r1311  
    533533qed.
    534534
    535 lemma make_initial_state_sound : ∀p. P_res ? (λgs.globalenv Genv ?? (fst ??) p = OK ? (\fst gs) ∧ initial_state p (\snd gs)) (make_initial_state p).
     535lemma make_initial_state_sound : ∀p. P_res ? (initial_state p) (make_initial_state p).
    536536#p cases p; #fns #main #vars
    537537whd in ⊢ (???%);
    538 @bind_OK #ge #Ege
    539538@bind_OK #m #Em
    540539@opt_bind_OK #x cases x; #sp #b #esb
    541540@opt_bind_OK #f #ef
    542 whd; % [ whd in ⊢ (???(??%)) // | @(initial_state_intro … Ege Em esb ef) ]
     541@(initial_state_intro … Em esb ef) @refl
    543542qed.
    544543
  • Deliverables/D3.3/id-lookup-branch/Clight/Csem.ma

    r1153 r1311  
    12111211inductive initial_state (p: clight_program): state -> Prop :=
    12121212  | initial_state_intro: ∀b,f,ge,m0.
    1213       globalenv Genv ?? (fst ??) p = OK ? ge →
     1213      globalenv Genv ?? (fst ??) p = ge →
    12141214      init_mem Genv ?? (fst ??) p = OK ? m0 →
    12151215      find_symbol ?? ge (prog_main ?? p) = Some ? b →
     
    12291229
    12301230definition exec_program : clight_program → program_behavior → Prop ≝ λp,beh.
    1231   ∀ge. globalenv ??? (fst ??) p = OK ? ge →
     1231  ∀ge. globalenv ??? (fst ??) p = ge →
    12321232  program_behaves (mk_transrel ?? step) (initial_state p) final_state ge beh.
    12331233 
  • Deliverables/D3.3/id-lookup-branch/Clight/Csyntax.ma

    r1153 r1311  
    318318  data.  See module [AST] for more details. *)
    319319
    320 definition clight_program : Type[0] ≝ program clight_fundef (list init_data × type).
     320definition clight_program : Type[0] ≝ program (λ_.clight_fundef) (list init_data × type).
    321321
    322322(* * * Operations over types *)
  • Deliverables/D3.3/id-lookup-branch/Clight/TypeComparison.ma

    r891 r1311  
    9191definition assert_type_eq : ∀t1,t2:type. res (t1 = t2) ≝
    9292λt1,t2. match type_eq_dec t1 t2 with [ inl p ⇒ OK ? p | inr _ ⇒ Error ? (msg TypeMismatch)].
     93
     94definition type_eq : type → type → bool ≝
     95λt1,t2. match type_eq_dec t1 t2 with [ inl _ ⇒ true | inr _ ⇒ false ].
     96
  • Deliverables/D3.3/id-lookup-branch/Clight/clightPrintMatita.ml

    r1197 r1311  
    466466  collect_program prog;
    467467  fprintf p "include \"Clight/Cexec.ma\".@\ninclude \"common/Animation.ma\".@\n@\n";
    468   fprintf p "@[<v 2>definition myprog := mk_program clight_fundef ((list init_data) × type)@ ";
     468  fprintf p "@[<v 2>definition myprog := mk_program (\\lambda _. clight_fundef) ((list init_data) × type)@ ";
    469469(*  StructUnionSet.iter (declare_struct_or_union p) !struct_unions;
    470470  StructUnionSet.iter (print_struct_or_union p) !struct_unions;*)
     471  print_list print_globvar p prog.prog_vars;
    471472  print_list print_fundef p prog.prog_funct;
    472473  fprintf p "@\n(ident_of_nat %i)@\n" (id_i "main");
    473   print_list print_globvar p prog.prog_vars;
    474   fprintf p "@;<0 -2>.@]@\n@\n";
     474  fprintf p "@;<0 -2>.@]@\n@\n(*@\n";
    475475  fprintf p "example exec: result ? (exec_up_to clight_fullexec myprog 1000 [EVint I32 (repr I32 0)]).@\n";
    476   fprintf p "normalize  (* you can examine the result here *)@."
     476  fprintf p "normalize  (* you can examine the result here *)@\n";
     477  fprintf p "*)@."
    477478
    478479let print_program prog =
  • Deliverables/D3.3/id-lookup-branch/Clight/label.ma

    r1056 r1311  
    187187
    188188definition clight_label : clight_program → res clight_program ≝
    189   transform_partial_program ??? label_fundef.
     189 λp. transform_partial_program … p label_fundef.
  • Deliverables/D3.3/id-lookup-branch/Clight/test/search.c.ma

    r1153 r1311  
    22include "common/Animation.ma".
    33
    4 definition myprog := mk_program clight_fundef ((list init_data) × type)
     4definition myprog := mk_program (λ_.clight_fundef) ((list init_data) × type)
     5  []
    56  [〈ident_of_nat 0 (* search *), CL_Internal (
    67     mk_function (Tint I8 Unsigned ) [〈ident_of_nat 4, (Tpointer Any (Tint I8 Unsigned ))〉 ; 〈ident_of_nat 5, (Tint I8 Unsigned )〉 ; 〈ident_of_nat 6, (Tint I8 Unsigned )〉 ] [〈ident_of_nat 1, (Tint I8 Unsigned )〉 ; 〈ident_of_nat 2, (Tint I8 Unsigned )〉 ; 〈ident_of_nat 3, (Tint I8 Unsigned )〉 ]
     
    181182  )〉]
    182183  (ident_of_nat 7)
    183   []
    184184.
    185185
     
    192192include "Cminor/semantics.ma".
    193193
     194example e1: finishes_with (repr I32 3) ? (bind ? (snapshot state) (clight_to_cminor myprog) (λp. exec_up_to Cminor_fullexec p 1000 [ ])).
     195(*
    194196example e1: finishes_with (repr I32 3) ? (do p ← clight_to_cminor myprog; exec_up_to Cminor_fullexec p 1000 [ ]).
     197*)
    195198normalize
    196199@refl
     
    202205example e2: finishes_with (repr 3) ? (
    203206do p1 ← clight_to_cminor myprog;
     207bind ? (snapshot state) (cminor_to_rtlabs p1) (λp2.
     208 exec_up_to RTLabs_fullexec p2 1000 [ ])).
     209(*
     210example e2: finishes_with (repr 3) ? (
     211do p1 ← clight_to_cminor myprog;
    204212do p2 ← cminor_to_rtlabs p1;
    205  exec_up_to RTLabs_fullexec p2 1000 [ ]).
     213 exec_up_to RTLabs_fullexec p2 1000 [ ]).*)
    206214normalize
    207215@refl
  • Deliverables/D3.3/id-lookup-branch/Clight/test/sum.c.ma

    r1153 r1311  
    22include "common/Animation.ma".
    33
    4 definition myprog := mk_program clight_fundef (list init_data × type)
    5   [〈ident_of_nat 0 (* main *), CL_Internal (
    6      mk_function (Tint I32 Signed  ) [] [〈ident_of_nat 1, (Tint I32 Signed  )〉 ; 〈ident_of_nat 2, (Tint I8 Unsigned )〉 ]
     4definition myprog := mk_program (\lambda _. clight_fundef) ((list init_data) × type)
     5  [〈〈ident_of_nat 0 (* src *), Any〉,
     6     〈[(Init_int8 (repr I8 28)) ; (Init_int8 (repr I8 17)) ;
     7        (Init_int8 (repr I8 17)) ; (Init_int8 (repr I8 8)) ;
     8        (Init_int8 (repr I8 4)) ], (Tarray Any (Tint I8 Unsigned ) 5)〉〉]
     9  [〈ident_of_nat 1 (* main *), CL_Internal (
     10     mk_function (Tint I32 Signed  ) [] [〈ident_of_nat 2, (Tint I32 Signed  )〉 ; 〈ident_of_nat 3, (Tint I8 Unsigned )〉 ]
    711       (Ssequence
    8        (Sassign (Expr (Evar (ident_of_nat 2)) (Tint I8 Unsigned ))
     12       (Sassign (Expr (Evar (ident_of_nat 3)) (Tint I8 Unsigned ))
    913         (Expr (Ecast (Tint I8 Unsigned )
    1014           (Expr (Econst_int I32 (repr ? 0)) (Tint I32 Signed  )))
    1115           (Tint I8 Unsigned )))
    1216       (Ssequence
    13        (Sfor (Sassign (Expr (Evar (ident_of_nat 1)) (Tint I32 Signed  ))
     17       (Sfor (Sassign (Expr (Evar (ident_of_nat 2)) (Tint I32 Signed  ))
    1418               (Expr (Econst_int I32 (repr ? 0)) (Tint I32 Signed  )))
    1519         (Expr (Ebinop Olt
    1620           (Expr (Ecast (Tint I32 Unsigned)
    17              (Expr (Evar (ident_of_nat 1)) (Tint I32 Signed  )))
     21             (Expr (Evar (ident_of_nat 2)) (Tint I32 Signed  )))
    1822             (Tint I32 Unsigned))
    1923           (Expr (Esizeof (Tarray Any (Tint I8 Unsigned ) 5))
    2024             (Tint I32 Unsigned))) (Tint I32 Signed  ))
    21          (Sassign (Expr (Evar (ident_of_nat 1)) (Tint I32 Signed  ))
     25         (Sassign (Expr (Evar (ident_of_nat 2)) (Tint I32 Signed  ))
    2226           (Expr (Ebinop Oadd
    23              (Expr (Evar (ident_of_nat 1)) (Tint I32 Signed  ))
     27             (Expr (Evar (ident_of_nat 2)) (Tint I32 Signed  ))
    2428             (Expr (Econst_int I32 (repr ? 1)) (Tint I32 Signed  )))
    2529             (Tint I32 Signed  )))
    26          (Sassign (Expr (Evar (ident_of_nat 2)) (Tint I8 Unsigned ))
     30         (Sassign (Expr (Evar (ident_of_nat 3)) (Tint I8 Unsigned ))
    2731           (Expr (Ecast (Tint I8 Unsigned )
    2832             (Expr (Ebinop Oadd
    2933               (Expr (Ecast (Tint I32 Signed  )
    30                  (Expr (Evar (ident_of_nat 2)) (Tint I8 Unsigned )))
     34                 (Expr (Evar (ident_of_nat 3)) (Tint I8 Unsigned )))
    3135                 (Tint I32 Signed  ))
    3236               (Expr (Ecast (Tint I32 Signed  )
    3337                 (Expr (Ederef
    3438                   (Expr (Ebinop Oadd
    35                      (Expr (Evar (ident_of_nat 3))
     39                     (Expr (Evar (ident_of_nat 0))
    3640                       (Tarray Any (Tint I8 Unsigned ) 5))
    37                      (Expr (Evar (ident_of_nat 1)) (Tint I32 Signed  )))
     41                     (Expr (Evar (ident_of_nat 2)) (Tint I32 Signed  )))
    3842                     (Tpointer Any (Tint I8 Unsigned ))))
    3943                   (Tint I8 Unsigned ))) (Tint I32 Signed  )))
     
    4145       )
    4246       (Sreturn (Some expr (Expr (Ecast (Tint I32 Signed  )
    43                              (Expr (Evar (ident_of_nat 2))
     47                             (Expr (Evar (ident_of_nat 3))
    4448                               (Tint I8 Unsigned ))) (Tint I32 Signed  ))))))
    4549     
     
    4751     
    4852   )〉]
    49   (ident_of_nat 0)
    50   [〈〈ident_of_nat 3 (* src *), Any〉,
    51      〈[(Init_int8 (repr I8 28)) ; (Init_int8 (repr I8 17)) ;
    52      (Init_int8 (repr I8 17)) ; (Init_int8 (repr I8 8)) ;
    53      (Init_int8 (repr I8 4)) ],
    54      (Tarray Any (Tint I8 Unsigned ) 5)〉〉]
     53  (ident_of_nat 1)
     54 
    5555.
    5656
    57 example exec: finishes_with (repr I32 74) ? (exec_up_to clight_fullexec myprog 1000 [ ]).
     57(*
     58example exec: result ? (exec_up_to clight_fullexec myprog 1000 [EVint I32 (repr I32 0)]).
    5859normalize  (* you can examine the result here *)
    59 @refl
    60 qed.
    61 
    62 include "Clight/toCminor.ma".
    63 include "Cminor/semantics.ma".
    64 
    65 example e1: finishes_with (repr I32 74) ? (do p ← clight_to_cminor myprog; exec_up_to Cminor_fullexec p 1000 [ ]).
    66 normalize
    67 @refl
    68 qed.
    69 
    70 include "Cminor/toRTLabs.ma".
    71 include "RTLabs/semantics.ma".
    72 
    73 example e2: finishes_with (repr I32 74) ? (
    74 do p1 ← clight_to_cminor myprog;
    75 do p2 ← cminor_to_rtlabs p1;
    76  exec_up_to RTLabs_fullexec p2 1000 [ ]).
    77 normalize
    78 @refl
    79 qed.
     60*)
  • Deliverables/D3.3/id-lookup-branch/Clight/toCminor.ma

    r1197 r1311  
    694694axiom FIXME : String.
    695695
     696record tmpgen : Type[0] ≝ {
     697  tmp_universe : universe SymbolTag;
     698  tmp_env : list (ident × typ)
     699}.
     700
     701definition alloc_tmp : memory_chunk → tmpgen → ident × tmpgen ≝
     702λc,g.
     703  let 〈tmp,u〉 ≝ fresh ? (tmp_universe g) in
     704  〈tmp, mk_tmpgen u (〈tmp, typ_of_memory_chunk c〉::(tmp_env g))〉.
     705
    696706lemma lookup_label_hit : ∀lbls,l,l'.
    697707  lookup_label lbls l = OK ? l' →
     
    700710qed.
    701711
    702 definition trans_inv : var_types → lenv → statement → stmt → Prop ≝
    703 λvars,lbls,s,s'. stmt_inv vars lbls s' ∧ labels_translated lbls s s'.
    704 
    705 lemma trans_inv_stmt_inv : ∀vars,lbls,s,s'.
    706   trans_inv vars lbls s s' → stmt_inv vars lbls s'.
    707 #var #lbls #s #s' * //
     712definition add_tmps : var_types → tmpgen → var_types ≝
     713λvs,g.
     714  foldr ?? (λidty,vs. add ?? vs (\fst idty) Local) vs (tmp_env g).
     715
     716definition tmps_preserved : var_types → tmpgen → tmpgen → Prop ≝
     717λvars,u1,u2.
     718  ∀id. local_id (add_tmps vars u1) id → local_id (add_tmps vars u2) id.
     719
     720lemma alloc_tmp_preserves : ∀tmp,u,u',vars,q.
     721  〈tmp,u'〉 = alloc_tmp q u → tmps_preserved vars u u'.
     722#tmp #g #g' #vars #q
     723whd in ⊢ (???% → ?)
     724generalize in ⊢ (???(match % with [ _ ⇒ ? ]) → ?)
     725* #tmp' #u whd in ⊢ (???% → ?) #E
     726>(pair_eq2 ?????? E)
     727#id #H
     728whd in ⊢ (?%?) whd whd in ⊢ match % with [ _ ⇒ ? | _ ⇒ ? ]
     729cases (identifier_eq ? id tmp')
     730[ #E1 >E1 >lookup_add_hit @I
     731| * #NE >lookup_add_miss [ @H | @eq_identifier_elim // #E1 cases (NE E1)
     732] qed.
     733
     734definition trans_inv : var_types → lenv → statement → tmpgen → (stmt×tmpgen) → Prop ≝
     735λvars,lbls,s,u,su'.
     736  let 〈s',u'〉 ≝ su' in
     737  stmt_inv (add_tmps vars u') lbls s' ∧
     738  labels_translated lbls s s' ∧
     739  tmps_preserved vars u u'.
     740
     741lemma trans_inv_stmt_inv : ∀vars,lbls,s,u,su.
     742  trans_inv vars lbls s u su → stmt_inv (add_tmps vars (\snd su)) lbls (\fst su).
     743#var #lbls #s #u * #s' #u' * * #H1 #H2 #H3 @H1
    708744qed.
    709745
    710 lemma trans_inv_labels : ∀vars,lbls,s,s'.
    711   trans_inv vars lbls s s' → labels_translated lbls s s'.
    712 #vars #lbls #s #s' @proj2
     746lemma trans_inv_labels : ∀vars,lbls,s,u,su.
     747  trans_inv vars lbls s u su → labels_translated lbls s (\fst su).
     748#vars #lbls #s #u * #s' #u' * * #_ #H #_ @H
    713749qed.
    714750
    715 
    716 let rec translate_statement (vars:var_types) (lbls:lenv) (tmp:Σi:ident.local_id vars i) (tmpp:Σi:ident.local_id vars i) (s:statement) on s : res (Σs':stmt.trans_inv vars lbls s s') ≝
    717 match s return λs.res (Σs':stmt.trans_inv vars lbls s s') with
    718 [ Sskip ⇒ OK ? «St_skip, ?»
     751lemma local_id_add_local_oblivious : ∀vars,id,id'.
     752  local_id vars id → local_id (add ?? vars id' Local) id.
     753#vars #id #id' #H whd whd in ⊢ (match % with [ _ ⇒ ? | _ ⇒ ? ])
     754cases (identifier_eq ? id id')
     755[ #E >E >lookup_add_hit @I
     756| * #NE >lookup_add_miss [ @H | @eq_identifier_elim // #E cases (NE E)
     757] qed.
     758
     759lemma local_id_add_tmps_oblivious : ∀vars,id,u.
     760  local_id vars id → local_id (add_tmps vars u) id.
     761#vars #id * #u #l #H elim l
     762[ //
     763| * #id' #ty #tl @local_id_add_local_oblivious
     764] qed.
     765
     766lemma add_tmps_oblivious : ∀vars,lbls,s,u.
     767  stmt_inv vars lbls s → stmt_inv (add_tmps vars u) lbls s.
     768#vars #lbls #s #u #H
     769@(stmt_P_mp … H)
     770#s' * #H1 #H2 %
     771[ @(stmt_vars_mp … H1)
     772  #id @local_id_add_tmps_oblivious
     773| @H2
     774] qed.
     775
     776lemma local_id_fresh_tmp : ∀tmp,u,q,u0,vars.
     777  〈tmp,u〉 = alloc_tmp q u0 → local_id (add_tmps vars u) tmp.
     778#tmp #u #q #u0 #vars
     779whd in ⊢ (???% → ?)
     780generalize in ⊢ (???(match % with [ _ ⇒ ? ]) → ?)
     781* #tmp' #u' whd in ⊢ (???% → ?) #E
     782>(pair_eq1 ?????? E) >(pair_eq2 ?????? E)
     783whd in ⊢ (?%?) whd whd in ⊢ match % with [ _ ⇒ ? | _ ⇒ ? ] >lookup_add_hit
     784@I
     785qed.
     786
     787lemma use_sig' : ∀A.∀P,P':A → Prop. (∀x.P x → P' x) → ∀x:Σx:A.P x. P' x.
     788#A #P #P' #H1 * #x #H2 @H1 @H2
     789qed.
     790
     791definition sigbind2 : ∀A,B,C:Type[0]. ∀P:A×B → Prop. res (Σx:A×B.P x) → (∀a,b. P 〈a,b〉 → res C) → res C ≝
     792λA,B,C,P,e,f.
     793  match e with
     794  [ OK v ⇒ match v with [ dp v' p ⇒ match v' return λv'. P v' → res C with [ pair a b ⇒ f a b ] p ]
     795  | Error msg ⇒ Error ? msg
     796  ].
     797
     798notation > "vbox('do' 〈ident v1, ident v2〉 'with' ident H ← e; break e')" with precedence 40 for @{'sigbind2 ${e} (λ${ident v1}.λ${ident v2}.λ${ident H}.${e'})}.
     799(*
     800notation > "vbox('do' 〈ident v1 : ty1, ident v2 : ty2〉 ← e; break e')" with precedence 40 for @{'bind2 ${e} (λ${ident v1} : ${ty1}.λ${ident v2} : ${ty2}.${e'})}.
     801notation < "vbox('do' \nbsp 〈ident v1, ident v2〉 ← e; break e')" with precedence 40 for @{'bind2 ${e} (λ${ident v1}.λ${ident v2}.${e'})}.
     802notation < "vbox('do' \nbsp 〈ident v1 : ty1, ident v2 : ty2〉 ← e; break e')" with precedence 40 for @{'bind2 ${e} (λ${ident v1} : ${ty1}.λ${ident v2} : ${ty2}.${e'})}.
     803*)
     804interpretation "error monad sig Prod bind" 'sigbind2 e f = (sigbind2 ???? e f).
     805
     806let rec translate_statement (vars:var_types) (lbls:lenv) (u:tmpgen) (s:statement) on s : res (Σsu:stmt×tmpgen.trans_inv vars lbls s u su) ≝
     807match s return λs.res (Σsu:stmt×tmpgen.trans_inv vars lbls s u su) with
     808[ Sskip ⇒ OK ? «〈St_skip, u〉, ?»
    719809| Sassign e1 e2 ⇒
    720810    do s' ← translate_assign vars e1 e2;
    721     OK ? «eject ?? s', ?»
     811    OK ? «〈eject ?? s', u〉, ?»
    722812| Scall ret ef args ⇒
    723813    do ef' ← translate_expr vars ef;
     
    725815    do args' ← mmap_sigma … (translate_expr_sigma vars) args;
    726816    match ret with
    727     [ None ⇒ OK ? «St_call (None ?) ef' args', ?»
     817    [ None ⇒ OK ? «〈St_call (None ?) ef' args', u〉, ?»
    728818    | Some e1 ⇒
    729819        do dest ← translate_dest vars e1 (typeof e1); (* TODO: check if it's sane to use e1's type rather than the return type *)
    730820        match dest with
    731         [ IdDest id p ⇒ OK ? «St_call (Some ? id) ef' args', ?»
     821        [ IdDest id p ⇒ OK ? «〈St_call (Some ? id) ef' args', u〉, ?»
    732822        | MemDest r q e1' ⇒
    733             let tmp' ≝ match q with [ Mpointer _ ⇒ tmpp | _ ⇒ tmp ] in
    734             OK ? «St_seq (St_call (Some ? tmp) ef' args') (St_store (typ_of_memory_chunk q) r q e1' (Id ? tmp)), ?»
     823            let 〈tmp, u〉 as Etmp ≝ alloc_tmp q u in
     824            OK ? «〈St_seq (St_call (Some ? tmp) ef' args') (St_store (typ_of_memory_chunk q) r q e1' (Id ? tmp)), u〉, ?»
    735825        ]
    736826    ]
    737827| Ssequence s1 s2 ⇒
    738     do s1' ← translate_statement vars lbls tmp tmpp s1;
    739     do s2' ← translate_statement vars lbls tmp tmpp s2;
    740     OK ? «St_seq s1' s2', ?»
     828    do 〈s1', u1〉 with H1 ← translate_statement vars lbls u s1;
     829    do 〈s2', u2〉 with H2 ← translate_statement vars lbls u1 s2;
     830    OK ? «〈St_seq s1' s2', u2〉, ?»
    741831| Sifthenelse e1 s1 s2 ⇒
    742832    do e1' ← translate_expr vars e1;
    743833    match typ_of_type (typeof e1) return λx.(Σe:CMexpr x.expr_vars ? e ?) → ? with
    744834    [ ASTint _ _ ⇒ λe1'.
    745         do s1' ← translate_statement vars lbls tmp tmpp s1;
    746         do s2' ← translate_statement vars lbls tmp tmpp s2;
    747         OK ? «St_ifthenelse ?? e1' s1' s2', ?»
     835        do 〈s1', u〉 with H1 ← translate_statement vars lbls u s1;
     836        do 〈s2', u〉 with H2 ← translate_statement vars lbls u s2;
     837        OK ? «〈St_ifthenelse ?? e1' s1' s2', u〉, ?»
    748838    | _ ⇒ λ_.Error ? (msg TypeMismatch)
    749839    ] e1'
     
    752842    match typ_of_type (typeof e1) return λx.(Σe:CMexpr x.expr_vars ? e ?) → ? with
    753843    [ ASTint _ _ ⇒ λe1'.
    754         do s1' ← translate_statement vars lbls tmp tmpp s1;
     844        do 〈s1', u〉 with H1 ← translate_statement vars lbls u s1;
    755845        (* TODO: this is a little different from the prototype and CompCert, is it OK? *)
    756         OK ? «St_block
     846        OK ? «St_block
    757847               (St_loop
    758                  (St_ifthenelse ?? e1' (St_block s1') (St_exit 0))),
     848                 (St_ifthenelse ?? e1' (St_block s1') (St_exit 0))), u〉,
    759849    | _ ⇒ λ_.Error ? (msg TypeMismatch)
    760850    ] e1'
     
    763853    match typ_of_type (typeof e1) return λx.(Σe:CMexpr x. expr_vars ? e ?) → ? with
    764854    [ ASTint _ _ ⇒ λe1'.
    765         do s1' ← translate_statement vars lbls tmp tmpp s1;
     855        do 〈s1',u〉 with H1 ← translate_statement vars lbls u s1;
    766856        (* TODO: this is a little different from the prototype and CompCert, is it OK? *)
    767         OK ? «St_block
     857        OK ? «St_block
    768858               (St_loop
    769                  (St_seq (St_block s1') (St_ifthenelse ?? e1' St_skip (St_exit 0)))),
     859                 (St_seq (St_block s1') (St_ifthenelse ?? e1' St_skip (St_exit 0)))), u〉,
    770860    | _ ⇒ λ_.Error ? (msg TypeMismatch)
    771861    ] e1'
     
    774864    match typ_of_type (typeof e1) return λx.(Σe:CMexpr x. expr_vars ? e ?) → ? with
    775865    [ ASTint _ _ ⇒ λe1'.
    776         do s1' ← translate_statement vars lbls tmp tmpp s1;
    777         do s2' ← translate_statement vars lbls tmp tmpp s2;
    778         do s3' ← translate_statement vars lbls tmp tmpp s3;
     866        do 〈s1', u〉 with H1 ← translate_statement vars lbls u s1;
     867        do 〈s2', u〉 with H2 ← translate_statement vars lbls u s2;
     868        do 〈s3', u〉 with H3 ← translate_statement vars lbls u s3;
    779869        (* TODO: this is a little different from the prototype and CompCert, is it OK? *)
    780         OK ? «St_seq s1'
     870        OK ? «St_seq s1'
    781871             (St_block
    782872               (St_loop
    783                  (St_ifthenelse ?? e1' (St_seq (St_block s3') s2') (St_exit 0)))),
     873                 (St_ifthenelse ?? e1' (St_seq (St_block s3') s2') (St_exit 0)))), u〉,
    784874    | _ ⇒ λ_.Error ? (msg TypeMismatch)
    785875    ] e1'
    786 | Sbreak ⇒ OK ? «St_exit 1, ?»
    787 | Scontinue ⇒ OK ? «St_exit 0, ?»
     876| Sbreak ⇒ OK ? «〈St_exit 1, u〉, ?»
     877| Scontinue ⇒ OK ? «〈St_exit 0, u〉, ?»
    788878| Sreturn ret ⇒
    789879    match ret with
    790     [ None ⇒ OK ? «St_return (None ?), ?»
     880    [ None ⇒ OK ? «〈St_return (None ?), u〉, ?»
    791881    | Some e1 ⇒
    792882        do e1' ← translate_expr vars e1;
    793         OK ? «St_return (Some ? (dp … e1')), ?»
     883        OK ? «〈St_return (Some ? (dp … e1')), u〉, ?»
    794884    ]
    795885| Sswitch e1 ls ⇒ Error ? (msg FIXME)
    796886| Slabel l s1 ⇒
    797887    do l' as E ← lookup_label lbls l;
    798     do s1' ← translate_statement vars lbls tmp tmpp s1;
    799     OK ? «St_label l' s1', ?»
     888    do 〈s1', u〉 with H1 ← translate_statement vars lbls u s1;
     889    OK ? «〈St_label l' s1', u〉, ?»
    800890| Sgoto l ⇒
    801891    do l' as E ← lookup_label lbls l;
    802     OK ? «St_goto l', ?»
     892    OK ? «〈St_goto l', u〉, ?»
    803893| Scost l s1 ⇒
    804     do s1' ← translate_statement vars lbls tmp tmpp s1;
    805     OK ? «St_cost l s1', ?»
    806 ].
    807 try @conj try @conj try @conj try @conj try @conj try @conj try @conj try @conj try @conj try @conj
     894    do 〈s1', u〉 with H1 ← translate_statement vars lbls u s1;
     895    OK ? «〈St_cost l s1', u〉, ?»
     896].
     897try @conj try @conj try @conj try @conj try @conj try @conj try @conj try @conj try @conj try @conj try @conj
    808898try @I
    809 try @(trans_inv_stmt_inv ???? (use_sig ? (λs.trans_inv ??? s) …))
    810 try @(use_sig ? (λs.stmt_inv ?? s))
    811 try @(use_sig ? (λe.expr_vars ? e ?))
    812 try @(use_sig ? (λs.stmt_vars ?? s))
    813 try @(use_sig ? (λs.stmt_labels ?? s))
    814 try @(use_sig ? (All ??))
    815 try @(use_sig ? (local_id vars))
    816 try @(lookup_label_hit … E)
    817 [ 1,3,5,6,7,13,14,15,16,18: whd #l *
    818 | @(use_sig ?? s')
    819 | @p
     899try (#l #H @(match H in False with [ ]))
     900try (#id #H @H)
     901[ @add_tmps_oblivious @(use_sig ?? s')
     902| @local_id_add_tmps_oblivious @p
     903]
     904try (@use_sig' #x @expr_vars_mp #i @local_id_add_tmps_oblivious)
     905[ 1,3,6: @use_sig' #x @All_mp * #ty #e @expr_vars_mp #i @local_id_add_tmps_oblivious
     906| 2,4: @(local_id_fresh_tmp … Etmp)
     907| @(alloc_tmp_preserves … Etmp)
     908| 7,11: @(stmt_P_mp … (π1 (π1 H1))) #s * #H3 #H4 % [ 1,3: @(stmt_vars_mp … H3) cases H2 #_ #H @H | *: @H4 ]
     909| 8,12: @(trans_inv_stmt_inv … H2)
     910| 9,13: #l #H cases (Exists_append … H)
     911  [ 1,3: #H3 cases H1 * #S1 #L1 #T1 cases (L1 l H3) #l' * #E1 #D1
     912    %{l'} % [ 1,3: @E1 | *: @Exists_append_l @D1 ]
     913  | *: #H3 cases H2 * #S2 #L2 #T2 cases (L2 l H3) #l' * #E2 #D2
     914    %{l'} % [ 1,3: @E2 | *: @Exists_append_r @D2 ]
     915  ]
     916| 10,14: cases H2 #_ #TP2 #id #L @TP2 cases H1 #_ #TP1 @TP1 @L
     917| 15,18: @(π1 (π1 H1))
     918| 16,19: cases H1 * #_ #L1 #_ #l #H cases (L1 l H) #l' * #E1 #D1
     919  %{l'} % [ 1,3: @E1 | *: @Exists_append_l @D1 ]
     920| 17,20: @(π2 H1)
     921(* Sfor *)
     922| @(stmt_P_mp … (π1 (π1 H1))) #s * #H4 #H5 % [ @(stmt_vars_mp … H4) #id #H @(π2 H3) @(π2 H2) @H | @H5 ]
     923| @(π1 (π1 H3))
     924| @(stmt_P_mp … (π1 (π1 H2))) #s * #H4 #H5 % [ @(stmt_vars_mp … H4) #id #H @(π2 H3) @H | @H5 ]
    820925| #l #H cases (Exists_append … H)
    821   [ #H1 cases s1' #s1' * #S1 #L1 cases (L1 l H1) #l' * #E1 #D1
     926  [ #EX1 cases H1 * #S1 #L1 #_ cases (L1 l EX1) #l' * #E1 #D1
    822927    %{l'} % [ @E1 | @Exists_append_l @D1 ]
    823   | #H2 cases s2' #s2' * #S2 #L2 cases (L2 l H2) #l' * #E2 #D2
    824     %{l'} % [ @E2 | @Exists_append_r @D2 ]
    825   ]
    826 | #l #H cases (Exists_append … H)
    827   [ #H1 cases s1' #s1' * #S1 #L1 cases (L1 l H1) #l' * #E1 #D1
    828     %{l'} % [ @E1 | @Exists_append_l @D1 ]
    829   | #H2 cases s2' #s2' * #S2 #L2 cases (L2 l H2) #l' * #E2 #D2
    830     %{l'} % [ @E2 | @Exists_append_r @D2 ]
    831   ]
    832 | cases s1' #s1' * #S1 #L1 #l #H cases (L1 l H) #l' * #E1 #D1
    833   %{l'} % [ @E1 | @Exists_append_l @D1 ]
    834 | cases s1' #s1' * #S1 #L1 #l #H cases (L1 l H) #l' * #E1 #D1
    835   %{l'} % [ @E1 | @Exists_append_l @D1 ]
    836 | #l #H cases (Exists_append … H)
    837   [ #H1 cases s1' #s1' * #S1 #L1 cases (L1 l H1) #l' * #E1 #D1
    838     %{l'} % [ @E1 | @Exists_append_l @D1 ]
    839   | #H cases (Exists_append … H)
    840     [ #H2 cases s2' #s2' * #S2 #L2 cases (L2 l H2) #l' * #E2 #D2
     928  | #EX cases (Exists_append … EX)
     929    [ #EX2 cases H2 * #S2 #L2 #_ cases (L2 l EX2) #l' * #E2 #D2
    841930      %{l'} % [ @E2 | @Exists_append_r @Exists_append_l @Exists_append_r @D2 ]
    842     | #H3 cases s3' #s3' * #S3 #L3 cases (L3 l H3) #l' * #E3 #D3
     931    | #EX3 cases H3 * #S3 #L3 #_ cases (L3 l EX3) #l' * #E3 #D3
    843932      %{l'} % [ @E3 | @Exists_append_r @Exists_append_l @Exists_append_l @D3 ]
    844933    ]
    845934  ]
    846 | cases s1' #s1' * #S1 #L1 #l0 *
    847   [ #El <El %{l'} >E % [ @refl | %1 @refl ]
    848   | #H cases (L1 l0 H) #l0' * #E1 #D1
    849     %{l0'} % [ @E1 | %2 @D1 ]
    850   ]
    851 | cases s1' #s1' * #S1 #L1 @L1
     935| #id #H @(π2 H3) @(π2 H2) @(π2 H1) @H
     936(* Slabel *)
     937| %{l} @E
     938| @(π1 (π1 H1))
     939| #l'' * [ #E <E %{l'} % // %1 @refl | #EX cases (π2 (π1 H1) l'' EX) #l4 * #LK #LD %{l4} % // %2 @LD ]
     940| @(π2 H1)
     941(* Sgoto *)
     942| %{l} @E
     943| @(π1 (π1 H1))
     944(* Scost *)
     945| @(π2 (π1 H1))
     946| @(π2 H1)
    852947] qed.
    853948
     
    856951
    857952(* ls and s0 aren't real parameters, they're just there for giving the invariant. *)
    858 definition alloc_params : ∀vars:var_types.∀ls,s0. list (ident×type) → (Σs:stmt. trans_inv vars ls s0 s) → res (Σs:stmt.trans_inv vars ls s0 s) ≝
    859 λvars,ls,s0,params,s. foldl ?? (λs,it.
     953definition alloc_params : ∀vars:var_types.∀ls,s0,u. list (ident×type) → (Σsu:stmt×tmpgen. trans_inv vars ls s0 u su) → res (Σsu:stmt×tmpgen.trans_inv vars ls s0 u su) ≝
     954λvars,ls,s0,u,params,s. foldl ?? (λsu,it.
    860955  let 〈id,ty〉 ≝ it in
    861   do s ← s;
     956  do 〈s,u〉 with Is ← su;
    862957  do t as E ← lookup' vars id;
    863958  match t return λx.? → ? with
    864   [ Local ⇒ λE. OK (Σs:stmt.?) s
     959  [ Local ⇒ λE. OK (Σs:stmt×tmpgen.?) «〈s,u〉,Is»
    865960  | Stack n ⇒ λE.
    866961      do q ← match access_mode ty with
     
    869964      | By_nothing ⇒ Error ? [MSG BadlyTypedAccess; CTX ? id]
    870965      ];
    871       OK ? «St_seq (St_store ? Any q (Cst ? (Oaddrstack n)) (Id (typ_of_type ty) id)) s, ?»
     966      OK ? «〈St_seq (St_store ? Any q (Cst ? (Oaddrstack n)) (Id (typ_of_type ty) id)) s, u〉, ?»
    872967  | Global _ ⇒ λE. Error ? [MSG ParamGlobalMixup; CTX ? id]
    873968  ] E) (OK ? s) params.
    874 try @conj try @conj try @conj try @conj try @conj
     969try @conj try @conj try @conj try @conj try @conj try @conj
    875970try @I
    876 [ whd >E @I
    877 | @(trans_inv_stmt_inv … s0) @(use_sig … s)
    878 | cases s #s * #S #L @L
    879 ] qed.
    880 
    881 definition bigid1 ≝ an_identifier SymbolTag [[
    882 false;true;false;false;
    883 false;false;false;false;
    884 false;false;false;false;
    885 false;false;false;false]].
    886 definition bigid2 ≝ an_identifier SymbolTag [[
    887 false;true;false;false;
    888 false;false;false;false;
    889 false;false;false;false;
    890 false;false;false;true]].
    891 
     971[ @(expr_vars_mp … (λid. local_id_add_tmps_oblivious vars id u)) whd >E @I
     972| @(π1 (π1 Is))
     973| @(π2 (π1 Is))
     974| @(π2 Is)
     975] qed.
     976
     977(*
    892978lemma local_id_add_local : ∀vars,id,id'.
    893979  local_id vars id →
     
    898984| #NE >lookup_add_miss // @eq_identifier_elim // #E cases NE >E /2/
    899985] qed.
    900 
     986*)
    901987axiom DuplicateLabel : String.
    902988
     
    9551041qed.
    9561042
    957 (* FIXME: the temporary handling is nonsense, I'm afraid. *)
    958 definition translate_function : list (ident×region) → function → res internal_function ≝
    959 λglobals, f.
     1043lemma local_id_split : ∀vars,tmpgen,i.
     1044  local_id (add_tmps vars tmpgen) i →
     1045  local_id vars i ∨ Exists ? (λx.\fst x = i) (tmp_env tmpgen).
     1046#vars #tmpgen #i
     1047whd in ⊢ (?%? → ?)
     1048elim (tmp_env tmpgen)
     1049[ #H %1 @H
     1050| * #id #ty #tl #IH
     1051  cases (identifier_eq ? i id)
     1052  [ #E >E #H %2 whd %1 @refl
     1053  | * #NE #H cases (IH ?)
     1054    [ #H' %1 @H'
     1055    | #H' %2 %2 @H'
     1056    | whd in H; whd in H:(match % with [ _ ⇒ ? | _ ⇒ ? ]);
     1057      >lookup_add_miss in H; [ #H @H | @eq_identifier_elim // #E cases (NE E) ]
     1058    ]
     1059  ]
     1060] qed.
     1061
     1062lemma Exists_squeeze : ∀A,P,l1,l2,l3.
     1063  Exists A P (l1@l3) → Exists A P (l1@l2@l3).
     1064#A #P #l1 #l2 #l3 #EX
     1065cases (Exists_append … EX)
     1066[ #EX1 @Exists_append_l @EX1
     1067| #EX3 @Exists_append_r @Exists_append_r @EX3
     1068] qed.
     1069
     1070definition translate_function : universe SymbolTag → list (ident×region) → function → res internal_function ≝
     1071λtmpuniverse, globals, f.
    9601072  do «lbls, Ilbls» ← build_label_env (fn_body f);
    961   let 〈vartypes0, stacksize〉 as E ≝ characterise_vars globals f in
    962   let tmp ≝ bigid1 in (* FIXME *)
    963   let tmpp ≝ bigid2 in (* FIXME *)
    964   let vartypes ≝ add … (add … vartypes0 tmp Local) tmpp Local in
    965   do s ← translate_statement vartypes lbls tmp tmpp (fn_body f);
    966   do «s,Is» ← alloc_params vartypes lbls ? (fn_params f) s;
     1073  let 〈vartypes, stacksize〉 as E ≝ characterise_vars globals f in
     1074  let tmp ≝ mk_tmpgen tmpuniverse [ ] in
     1075  do s ← translate_statement vartypes lbls tmp (fn_body f);
     1076  do 〈s,tmp〉 with Is ← alloc_params vartypes lbls ?? (fn_params f) s;
    9671077  OK ? (mk_internal_function
    9681078    (opttyp_of_type (fn_return f))
    9691079    (map ?? (λv.〈\fst v, typ_of_type (\snd v)〉) (fn_params f))
    970     (〈tmp,ASTint I32 Unsigned〉::〈tmpp,ASTptr Any〉::(map ?? (λv.〈\fst v, typ_of_type (\snd v)〉) (fn_vars f)))
     1080    ((tmp_env tmp)@(map ?? (λv.〈\fst v, typ_of_type (\snd v)〉) (fn_vars f)))
    9711081    stacksize
    9721082    s ?).
    973 [ cases Is #S #L
    974   @(stmt_P_mp ???? S)
    975   #s1 * #H1 #H2 %
    976   [ @(stmt_vars_mp … H1)
    977     #i #H cases (identifier_eq ? tmp i)
    978     [ #E <E @Exists_mid @refl
    979     | #NE1 @Exists_add cases (identifier_eq ? tmpp i)
    980       [ #E <E @Exists_mid @refl
    981       | #NE2 @Exists_add
    982         >map_append
    983         @Exists_map [ 2: @(characterise_vars_all … (sym_eq ??? E) i)
    984                          @(local_id_add_miss ?? Local ? NE1)
    985                          @(local_id_add_miss ?? Local ? NE2) @H
    986                     | skip
    987                     | * #id #ty #E1 <E1 @refl
    988                     ]
    989       ]
    990     ]
    991   | @(stmt_labels_mp … H2)
    992     #l * #l' #LOOKUP
    993     lapply (Ilbls l' l LOOKUP) #DEFINED
    994     cases (L … DEFINED) #lx * #LOOKUPx >LOOKUPx in LOOKUP #Ex destruct (Ex)
    995     #H @H
    996   ]
    997 | whd whd in ⊢ (match % with [ _ ⇒ ? | _ ⇒ ? ]) >lookup_add_miss [ >lookup_add_hit %| % ]
    998 | whd whd in ⊢ (match % with [ _ ⇒ ? | _ ⇒ ? ]) >lookup_add_hit %
    999 ] qed.
    1000 
    1001 definition translate_fundef : list (ident×region) → clight_fundef → res (fundef internal_function) ≝
    1002 λglobals,f.
     1083cases Is * #S #L #TP
     1084@(stmt_P_mp ???? S)
     1085#s1 * #H1 #H2 %
     1086[ @(stmt_vars_mp … H1)
     1087  #i #H
     1088  cases (local_id_split … H)
     1089  [ #H' @Exists_squeeze >map_append
     1090    @Exists_map [ 2: @(characterise_vars_all … (sym_eq ??? E) i) @H'
     1091                | skip
     1092                | * #id #ty #E1 <E1 @refl
     1093                ]
     1094  | #EX @Exists_append_r @Exists_append_l @EX
     1095  ]
     1096| @(stmt_labels_mp … H2)
     1097  #l * #l' #LOOKUP
     1098  lapply (Ilbls l' l LOOKUP) #DEFINED
     1099  cases (L … DEFINED) #lx * #LOOKUPx >LOOKUPx in LOOKUP #Ex destruct (Ex)
     1100  #H @H
     1101] qed.
     1102
     1103definition translate_fundef : universe SymbolTag → list (ident×region) → clight_fundef → res (fundef internal_function) ≝
     1104λtmpuniverse,globals,f.
    10031105match f with
    1004 [ CL_Internal fn ⇒ do fn' ← translate_function globals fn; OK ? (Internal ? fn')
     1106[ CL_Internal fn ⇒ do fn' ← translate_function tmpuniverse globals fn; OK ? (Internal ? fn')
    10051107| CL_External fn argtys retty ⇒ OK ? (External ? (mk_external_function fn (signature_of_type argtys retty)))
    10061108].
     1109
     1110(* TODO: move universe generation to higher level once we do runtime function
     1111   generation.  Cheating a bit - we only need the new identifiers to be fresh
     1112   for individual functions. *)
     1113include "Clight/fresh.ma".
    10071114
    10081115definition clight_to_cminor : clight_program → res Cminor_program ≝
    10091116λp.
     1117  let tmpuniverse ≝ universe_for_program p in
    10101118  let fun_globals ≝ map … (λid. 〈id,Code〉) (prog_funct_names ?? p) in
    10111119  let var_globals ≝ map … (λv. 〈\fst (\fst v), \snd (\fst v)〉) (prog_vars ?? p) in
    10121120  let globals ≝ fun_globals @ var_globals in
    1013   transform_partial_program2 ???? (translate_fundef globals) (λi. OK ? (\fst i)) p.
     1121  transform_partial_program2 … p (translate_fundef tmpuniverse globals) (λi. OK ? (\fst i)).
  • Deliverables/D3.3/id-lookup-branch/Cminor/cminorMatitaPrinter.ml

    r1197 r1311  
    352352
    353353let print_program p =
    354   Printf.sprintf "include \"Cminor/semantics.ma\".\ninclude \"common/Animation.ma\".\n\n%s\n\n%s\n\ndefinition myprog : Cminor_program :=\nmk_program ?? [\n%s\n]%s\n[%s]\n.\n"
     354  Printf.sprintf "include \"Cminor/semantics.ma\".\ninclude \"common/Animation.ma\".\n\n%s\n\n%s\n\ndefinition myprog : Cminor_program :=\nmk_program ?? [%s] [\n%s\n]%s\n.\n"
    355355    (define_var_ids p.Cminor.vars)
    356356    (print_functs p.Cminor.functs)
     357    (print_vars 2 p.Cminor.vars)
    357358    (print_fun' 2 p.Cminor.functs)
    358359    (print_main 2 p.Cminor.main)
    359     (print_vars 2 p.Cminor.vars)
    360 
     360
  • Deliverables/D3.3/id-lookup-branch/Cminor/initialisation.ma

    r1153 r1311  
    110110λp.
    111111  mk_program ??
     112    (empty_vars (prog_vars ?? p))
    112113    (add_statement (prog_main ?? p) (init_vars (prog_vars ?? p)) (prog_funct ?? p))
    113     (prog_main ?? p)
    114     (empty_vars (prog_vars ?? p)).
    115    
     114    (prog_main ?? p).
  • Deliverables/D3.3/id-lookup-branch/Cminor/semantics.ma

    r1153 r1311  
    459459].
    460460
    461 definition Cminor_exec : execstep io_out io_in ≝
    462   mk_execstep … ? is_final mem_of_state eval_step.
     461definition Cminor_exec : trans_system io_out io_in ≝
     462  mk_trans_system … ? (λ_.is_final) eval_step.
    463463
    464464axiom MainMissing : String.
    465465
    466 definition make_initial_state : Cminor_program → res (genv × state) ≝
     466definition make_global : Cminor_program → genv ≝
     467λp. globalenv Genv ?? (λx.x) p.
     468
     469definition make_initial_state : Cminor_program → res state ≝
    467470λp.
    468   do ge ← globalenv Genv ?? (λx.x) p;
     471  let ge ≝ make_global p in
    469472  do m ← init_mem Genv ?? (λx.x) p;
    470473  do b ← opt_to_res ? (msg MainMissing) (find_symbol ? ? ge (prog_main ?? p));
    471474  do f ← opt_to_res ? (msg MainMissing) (find_funct_ptr ? ? ge b);
    472   OK ? 〈ge, Callstate f (nil ?) m SStop〉.
     475  OK ? (Callstate f (nil ?) m SStop).
    473476
    474477definition Cminor_fullexec : fullexec io_out io_in ≝
    475   mk_fullexec … Cminor_exec ? make_initial_state.
    476 
    477 definition make_initial_noinit_state : Cminor_noinit_program → res (genv × state) ≝
     478  mk_fullexec … Cminor_exec make_global make_initial_state.
     479
     480definition make_noinit_global : Cminor_noinit_program → genv ≝
     481λp. globalenv Genv ?? (λx.[Init_space x]) p.
     482
     483definition make_initial_noinit_state : Cminor_noinit_program → res state ≝
    478484λp.
    479   do ge ← globalenv Genv ?? (λx.[Init_space x]) p;
     485  let ge ≝ make_noinit_global p in
    480486  do m ← init_mem Genv ?? (λx.[Init_space x]) p;
    481487  do b ← opt_to_res ? (msg MainMissing) (find_symbol ? ? ge (prog_main ?? p));
    482488  do f ← opt_to_res ? (msg MainMissing) (find_funct_ptr ? ? ge b);
    483   OK ? 〈ge, Callstate f (nil ?) m SStop〉.
     489  OK ? (Callstate f (nil ?) m SStop).
    484490
    485491definition Cminor_noinit_fullexec : fullexec io_out io_in ≝
    486   mk_fullexec … Cminor_exec ? make_initial_noinit_state.
     492  mk_fullexec … Cminor_exec make_noinit_global make_initial_noinit_state.
  • Deliverables/D3.3/id-lookup-branch/Cminor/syntax.ma

    r1153 r1311  
    155155   responsible for initialisation and we only give the size of each variable. *)
    156156
    157 definition Cminor_program ≝ program (fundef internal_function) (list init_data).
     157definition Cminor_program ≝ program (λ_.fundef internal_function) (list init_data).
    158158
    159 definition Cminor_noinit_program ≝ program (fundef internal_function) nat.
     159definition Cminor_noinit_program ≝ program (λ_.fundef internal_function) nat.
  • Deliverables/D3.3/id-lookup-branch/Cminor/test/search.Cminor.ma

    r1197 r1311  
    281281
    282282definition myprog : Cminor_program :=
    283 mk_program ?? [
     283mk_program ?? [] [
    284284  (pair ?? id__div32u f__div32u);
    285285  (pair ?? id__div32s f__div32s);
     
    287287  (pair ?? id_main f_main)
    288288]  id_main
    289 []
    290289.
    291 
    292    example exec: finishes_with (repr 3) ? (exec_up_to Cminor_fullexec myprog 1000 [ ]).
    293    normalize  (* you can examine the result here *)
    294    @refl qed.
    295 
    296 
    297 include "Cminor/toRTLabs.ma".
    298 include "RTLabs/semantics.ma".
    299 
    300 example execRTL: finishes_with (repr 3) ? (do myprog' ← cminor_to_rtlabs myprog; exec_up_to RTLabs_fullexec myprog' 1000 [ ]).
    301 normalize  (* you can examine the result here *)
    302 @refl
    303 qed.
    304 
    305 
  • Deliverables/D3.3/id-lookup-branch/Cminor/toRTLabs.ma

    r1153 r1311  
    719719
    720720definition cminor_noinit_to_rtlabs : Cminor_noinit_program → res RTLabs_program ≝
    721 transform_partial_program ???
    722   (transf_partial_fundef ?? c2ra_function).
     721λp.transform_partial_program … p (transf_partial_fundef … c2ra_function).
    723722
    724723include "Cminor/initialisation.ma".
  • Deliverables/D3.3/id-lookup-branch/ERTL/ERTL.ma

    r1197 r1311  
    1 include "ASM/I8051.ma".
    21include "joint/Joint.ma".
    3 include "utilities/BitVectorTrieSet.ma".
    4 include "utilities/IdentifierTools.ma".
    5 include "common/Graphs.ma".
    6 include "common/CostLabel.ma".
    7 include "common/Registers.ma".
    8 
    9 definition registers ≝ list register.
    102
    113inductive move_registers: Type[0] ≝
     
    146                 
    157inductive ertl_statement_extension: Type[0] ≝
    16   | ertl_st_ext_new_frame: label → ertl_statement_extension
    17   | ertl_st_ext_del_frame: label → ertl_statement_extension
    18   | ertl_st_ext_frame_size: register → label → ertl_statement_extension.
     8  | ertl_st_ext_new_frame: ertl_statement_extension
     9  | ertl_st_ext_del_frame: ertl_statement_extension
     10  | ertl_st_ext_frame_size: register → ertl_statement_extension.
    1911
    20 definition ertl_params: params ≝
    21  mk_params
    22    register register register register
    23      (move_registers × move_registers) register
    24        ertl_statement_extension unit (list register) nat.
     12definition ertl_params__: params__ ≝
     13 mk_params__ register register register register (move_registers × move_registers)
     14  register nat unit ertl_statement_extension.
     15definition ertl_params_: params_ ≝ graph_params_ ertl_params__.
     16definition ertl_params0: params0 ≝ mk_params0 ertl_params__ unit nat.
     17definition ertl_params1: params1 ≝ rtl_ertl_params1 ertl_params0.
     18definition ertl_params: ∀globals. params globals ≝ rtl_ertl_params ertl_params0.
    2519
    26 definition ertl_statement ≝ joint_statement ertl_params.
     20definition ertl_statement ≝ joint_statement ertl_params_.
    2721
    28 definition ertl_statement_graph ≝ λglobals. graph (ertl_statement globals).
     22definition ertl_internal_function ≝
     23  λglobals.joint_internal_function … (ertl_params globals).
    2924
    30 record ertl_internal_function (globals: list ident): Type[0] ≝
    31 {
    32   ertl_if_luniverse: universe LabelTag;
    33   ertl_if_runiverse: universe RegisterTag;
    34   ertl_if_params: nat;
    35   ertl_if_locals: registers;
    36   ertl_if_stacksize: nat;
    37   ertl_if_graph: ertl_statement_graph globals;
    38   ertl_if_entry: Σl: label. lookup ? ? ertl_if_graph l ≠ None ?;
    39   ertl_if_exit: Σl: label. lookup ? ? ertl_if_graph l ≠ None ?
    40 }.
    41 
    42 definition set_luniverse ≝
    43   λglobals  : list ident.
    44   λint_fun  : ertl_internal_function globals.
    45   λluniverse: universe LabelTag.
    46   let runiverse ≝ ertl_if_runiverse globals int_fun in
    47   let params    ≝ ertl_if_params globals int_fun in
    48   let locals    ≝ ertl_if_locals globals int_fun in
    49   let stacksize ≝ ertl_if_stacksize globals int_fun in
    50   let graph     ≝ ertl_if_graph globals int_fun in
    51   let entry     ≝ ertl_if_entry globals int_fun in
    52   let exit      ≝ ertl_if_exit globals int_fun in
    53     mk_ertl_internal_function globals
    54       luniverse runiverse params locals
    55       stacksize graph entry exit.
    56 
    57 definition ertl_function ≝ λglobals. fundef (ertl_internal_function globals).
    58  
    59 record ertl_program (globals: list ident): Type[0] ≝
    60 {
    61   ertl_pr_vars: list (ident × nat);
    62   ertl_pr_funcs: list (ident × (ertl_function globals));
    63   ertl_pr_main: option ident
    64 }.
    65 
    66 
    67 (* XXX: changed from O'Caml
    68   | ertl_st_addr_h: register → ident → label → ertl_statement
    69   | ertl_st_addr_l: register → ident → label → ertl_statement
    70 *)
    71 
    72 (* XXX: changed from O'Caml
    73   | ertl_st_opaccs_a: OpAccs → register → register → register → label → ertl_statement
    74   | ertl_st_opaccs_b: OpAccs → register → register → register → label → ertl_statement
    75 *)
     25definition ertl_program ≝ joint_program ertl_params.
  • Deliverables/D3.3/id-lookup-branch/ERTL/ERTLToLTL.ma

    r1197 r1311  
    22include "LTL/LTL.ma".
    33include "ERTL/spill.ma".
    4 include "ERTL/build.ma".
    5 include "utilities/Interference.ma".
    64include "ASM/Arithmetic.ma".
    7 
    8 (* XXX: change from O'Caml: former contents of ERTLToLTLI.ma *)
    9 
    10 inductive decision: Type[0] ≝
    11   | decision_spill: Byte → decision
    12   | decision_colour: Register → decision.
    13  
    14 definition interference_lookup ≝
    15   λglobals.
    16   λint_fun.
    17   λr.
    18   let 〈liveafter, graph〉 ≝ build globals int_fun in
    19   let lkup ≝ ig_lookup graph r in
    20     vm_find lkup colour_colouring.
    21  
    22 definition lookup: register → decision ≝
    23   λr.
    24   match ? r with
    25   [ colour_spill
    26  
    27 axiom lookup: register → decision.
    285
    296definition fresh_label ≝
     
    318  λluniv.
    329    fresh LabelTag luniv.
     10
     11definition ltl_statement_graph ≝
     12  λglobals.
     13    graph … (ltl_statement globals).
    3314
    3415definition add_graph ≝
     
    5132  λglobals.
    5233  λint_fun.
    53     colour_locals + (ertl_if_stacksize globals int_fun).
     34    colour_locals + (joint_if_stacksize globals (ertl_params globals) int_fun).
    5435
    5536definition stacksize ≝
    5637  λglobals.
    5738  λint_fun.
    58     colour_locals + (ertl_if_stacksize globals int_fun).
     39    colour_locals + (joint_if_stacksize globals (ertl_params globals) int_fun).
    5940
    6041definition adjust_off ≝
     
    6748
    6849definition get_stack:
    69  ∀globals. ertl_internal_function globals → graph (ltl_statement globals) → Register → Byte → label →
    70   ltl_statement globals × (graph (ltl_statement globals)) × (universe LabelTag)
    71 
     50 ∀globals. ertl_internal_function globals → graph (ltl_statement globals) → Register → Byte → label → ? ≝
    7251  λglobals: list ident.
    7352  λint_fun.
     
    7655  λoff.
    7756  λl.
     57  λoriginal_label.
    7858    let off ≝ adjust_off globals int_fun off in
    79     let luniv ≝ ertl_if_luniverse globals int_fun in
    80     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc r)) l) in
    81     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_load … globals it it it) l) in
    82     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc RegisterDPH)) l) in
    83     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_op2 … globals Addc it RegisterSPH) l) in
    84     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_int … globals RegisterA (zero ?)) l) in
    85     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc RegisterDPL)) l) in
    86     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_op2 … globals Add it RegisterSPL) l) in
    87       〈joint_st_sequential … ltl_params globals (joint_instr_int ? globals RegisterA off) l, graph, luniv〉.
     59    let luniv ≝ joint_if_luniverse globals (ertl_params globals) int_fun in
     60    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc r)) l) in
     61    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (LOAD … globals it it it) l) in
     62    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc RegisterDPH)) l) in
     63    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (OP2 … globals Addc it it RegisterSPH) l) in
     64    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (INT … globals RegisterA (zero ?)) l) in
     65    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc RegisterDPL)) l) in
     66    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (OP2 … globals Add it it RegisterSPL) l) in
     67      〈add_graph globals original_label (sequential (ltl_params globals) globals (INT … (ltl_params globals) globals RegisterA off) l) graph, luniv〉.
    8868
    8969definition set_stack:
    9070  ∀globals. ertl_internal_function globals → ltl_statement_graph globals → Byte
    91     → Register → label → ((ltl_statement globals) × (ltl_statement_graph globals) × (universe LabelTag))
     71    → Register → label → ?
    9272  λglobals: list ident.
    9373  λint_fun.
     
    9676  λr.
    9777  λl.
     78  λoriginal_label.
    9879  let off ≝ adjust_off globals int_fun off in
    99   let luniv ≝ ertl_if_luniverse globals int_fun in
    100   let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_store ltl_params … globals it it it) l) in
    101   let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (to_acc r)) l) in
    102   let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc RegisterDPH)) l) in
    103   let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_op2 … globals Addc it RegisterSPH) l) in
    104   let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_int … globals RegisterA (zero ?)) l) in
    105   let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc RegisterDPL)) l) in
    106   let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_op2 … globals Add it RegisterSPL) l) in
    107     〈joint_st_sequential … ltl_params globals (joint_instr_int ? globals RegisterA off) l, graph, luniv〉.
    108 
    109 definition write:
    110   ∀globals: list ident. ertl_internal_function globals → ltl_statement_graph globals → register → label →
    111     ? ≝
    112   λglobals: list ident.
    113   λint_fun.
     80  let luniv ≝ joint_if_luniverse globals (ertl_params globals) int_fun in
     81  let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (STORE … globals it it it) l) in
     82  let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (to_acc r)) l) in
     83  let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc RegisterDPH)) l) in
     84  let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (OP2 … globals Addc it it RegisterSPH) l) in
     85  let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (INT … globals RegisterA (zero ?)) l) in
     86  let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc RegisterDPL)) l) in
     87  let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (OP2 … globals Add it it RegisterSPL) l) in
     88    〈add_graph globals original_label (sequential (ltl_params globals) globals (INT … (ltl_params globals) globals RegisterA off) l) graph, luniv〉.
     89
     90
     91definition write ≝
     92  λglobals: list ident.
     93  λint_fun: ertl_internal_function globals.
     94  λvaluation.
     95  λcoloured_graph.
    11496  λgraph.
    11597  λr.
    11698  λl.
    117   match lookup r with
     99  λoriginal_label: label.
     100  match colouring valuation coloured_graph (inl … r) with
    118101  [ decision_spill off ⇒
    119     let 〈stmt, graph, luniv〉 ≝ set_stack globals int_fun graph off RegisterSST l in
    120     let 〈l, graph, int_fun〉 ≝ generate globals luniv graph stmt in
     102    let luniv ≝ joint_if_luniverse … int_fun in
     103    let 〈graph, luniv〉 ≝ set_stack globals int_fun graph (bitvector_of_nat … off) RegisterSST l original_label in
    121104      〈RegisterSST, l, graph, luniv〉
    122105  | decision_colour hwr ⇒
    123     let luniv ≝ ertl_if_luniverse globals int_fun in
     106    let luniv ≝ joint_if_luniverse globals (ertl_params globals) int_fun in
    124107      〈hwr, l, graph, luniv〉
    125108  ].
    126109
    127 definition read:
    128   ∀globals: list ident. ertl_internal_function globals → ltl_statement_graph globals → register
    129     → (Register → ltl_statement globals) → ? ≝
    130   λglobals.
    131   λint_fun.
     110definition read ≝
     111  λglobals: list ident.
     112  λint_fun: ertl_internal_function globals.
     113  λvaluation.
     114  λcoloured_graph.
    132115  λgraph.
    133116  λr.
    134117  λstmt.
    135   match lookup r with
    136   [ decision_colour hwr ⇒ generate globals (ertl_if_luniverse globals int_fun) graph (stmt hwr)
     118  λoriginal_label: label.
     119  match colouring valuation coloured_graph (inl … r) with
     120  [ decision_colour hwr ⇒
     121    let luniv ≝ joint_if_luniverse … int_fun in
     122      〈add_graph globals original_label (stmt hwr) graph, luniv〉
    137123  | decision_spill off ⇒
    138124    let temphwr ≝ RegisterSST in
    139     let 〈l, graph, luniv〉 ≝ generate globals (ertl_if_luniverse globals int_fun) graph (stmt temphwr) in
    140     let 〈stmt, graph, luniv〉 ≝ get_stack globals int_fun graph temphwr off l in
    141       generate globals luniv graph stmt
     125    let luniv ≝ joint_if_luniverse … int_fun in
     126    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (stmt temphwr) in
     127      get_stack globals int_fun graph temphwr (bitvector_of_nat … off) l original_label
    142128  ].
    143129
     
    149135  λsrc: decision.
    150136  λl: label.
     137  λoriginal_label: label.
    151138  match dest with
    152139  [ decision_colour dest_hwr ⇒
    153140    match src with
    154141    [ decision_colour src_hwr ⇒
    155       let luniv ≝ ertl_if_luniverse globals int_fun in
     142      let luniv ≝ joint_if_luniverse globals (ertl_params globals) int_fun in
    156143      if eq_Register dest_hwr src_hwr then
    157         〈joint_st_goto … globals l, graph, luniv〉
     144        〈add_graph globals original_label (GOTO … globals l) graph, luniv〉
    158145      else
    159         let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc dest_hwr)) l) in
    160           〈joint_st_sequential … globals (joint_instr_move … ltl_params globals (to_acc src_hwr)) l, graph, luniv〉
    161     | decision_spill src_off ⇒ get_stack globals int_fun graph dest_hwr src_off l
     146        let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc dest_hwr)) l) in
     147          〈add_graph globals original_label (sequential (ltl_params globals) globals (MOVE … globals (to_acc src_hwr)) l) graph, luniv〉
     148    | decision_spill src_off ⇒ get_stack globals int_fun graph dest_hwr (bitvector_of_nat … src_off) l original_label
    162149    ]
    163150  | decision_spill dest_off ⇒
    164151    match src with
    165     [ decision_colour src_hwr ⇒ set_stack globals int_fun graph dest_off src_hwr l
     152    [ decision_colour src_hwr ⇒ set_stack globals int_fun graph (bitvector_of_nat … dest_off) src_hwr l original_label
    166153    | decision_spill src_off ⇒
    167       let luniv ≝ ertl_if_luniverse globals int_fun in
    168       if eq_bv ? dest_off src_off then
    169         〈joint_st_goto … globals l, graph, luniv〉
     154      let luniv ≝ joint_if_luniverse globals (ertl_params globals) int_fun in
     155      if eq_nat dest_off src_off then
     156        〈add_graph globals original_label (GOTO … globals l) graph, luniv〉
    170157      else
    171158        let temp_hwr ≝ RegisterSST in
    172         let 〈stmt, graph, luniv〉 ≝ set_stack globals int_fun graph dest_off temp_hwr l in
    173         let 〈l, graph, luniv〉 ≝ generate globals luniv graph stmt in
    174           get_stack globals int_fun graph temp_hwr src_off l
     159        let 〈graph, luniv〉 ≝ set_stack globals int_fun graph (bitvector_of_nat … dest_off) temp_hwr l original_label in
     160          get_stack globals int_fun graph temp_hwr (bitvector_of_nat … src_off) l original_label
    175161    ]
    176162  ].
     
    181167  λgraph: ltl_statement_graph globals.
    182168  λl: label.
     169  λoriginal_label: label.
    183170  if eq_nat (stacksize globals int_fun) 0 then
    184     〈joint_st_goto ltl_params globals l, graph, (ertl_if_luniverse globals int_fun)〉
     171    let luniv ≝ joint_if_luniverse globals (ertl_params globals) int_fun in
     172      〈add_graph globals original_label (GOTO … globals l) graph, luniv〉
    185173  else
    186     let luniv ≝ ertl_if_luniverse globals int_fun in
    187     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential ltl_params globals (joint_instr_move … globals (from_acc RegisterSPH)) l) in
    188     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential ltl_params globals (joint_instr_op2 … globals Sub it RegisterDPH) l) in
    189     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential ltl_params globals (joint_instr_int … globals RegisterDPH (zero ?)) l) in
    190     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential ltl_params globals (joint_instr_move … globals (to_acc RegisterSPH)) l) in
    191     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential ltl_params globals (joint_instr_move … globals (from_acc RegisterSPL)) l) in
    192     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential ltl_params globals (joint_instr_op2 … globals Sub it RegisterDPL) l) in
    193     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential ltl_params globals (joint_instr_clear_carry … globals) l) in
    194     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential ltl_params globals (joint_instr_int … globals RegisterDPL (bitvector_of_nat ? (stacksize globals int_fun))) l) in
    195       〈joint_st_sequential ltl_params globals (joint_instr_move ltl_params globals (to_acc RegisterSPL)) l, graph, luniv〉.
     174    let luniv ≝ joint_if_luniverse globals (ertl_params globals) int_fun in
     175    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc RegisterSPH)) l) in
     176    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (OP2 … globals Sub it it RegisterDPH) l) in
     177    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (INT … globals RegisterDPH (zero ?)) l) in
     178    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (to_acc RegisterSPH)) l) in
     179    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc RegisterSPL)) l) in
     180    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (OP2 … globals Sub it it RegisterDPL) l) in
     181    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (CLEAR_CARRY … globals) l) in
     182    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (INT … globals RegisterDPL (bitvector_of_nat ? (stacksize globals int_fun))) l) in
     183      〈add_graph globals original_label (sequential (ltl_params globals) globals (MOVE … globals (to_acc RegisterSPL)) l) graph, luniv〉.
    196184
    197185definition delframe ≝
     
    200188  λgraph: graph (ltl_statement globals).
    201189  λl.
     190  λoriginal_label: label.
    202191  if eq_nat (stacksize globals int_fun) 0 then
    203     〈joint_st_goto ltl_params globals l, graph, ertl_if_luniverse globals int_fun〉
     192    let luniv ≝ joint_if_luniverse globals (ertl_params globals) int_fun in
     193      〈add_graph globals original_label (GOTO (ltl_params globals) globals l) graph, luniv〉
    204194  else
    205     let luniv ≝ ertl_if_luniverse globals int_fun in
    206     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential ltl_params globals (joint_instr_move … globals (from_acc RegisterSPH)) l) in
    207     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential ltl_params globals (joint_instr_op2 … globals Addc it RegisterSPH) l) in
    208     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential ltl_params globals (joint_instr_int … globals RegisterA (zero ?)) l) in
    209     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential ltl_params globals (joint_instr_move … globals (from_acc RegisterSPL)) l) in
    210     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential ltl_params globals (joint_instr_op2 … globals Add it RegisterSPL) l) in
    211       〈joint_st_sequential ltl_params globals (joint_instr_int ltl_params globals RegisterA (bitvector_of_nat ? (stacksize globals int_fun))) l, graph, luniv〉.
    212 
    213 definition translate_statement ≝
    214   λglobals: list ident.
    215   λint_fun.
     195    let luniv ≝ joint_if_luniverse globals (ertl_params globals) int_fun in
     196    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc RegisterSPH)) l) in
     197    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (OP2 … globals Addc it it RegisterSPH) l) in
     198    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (INT … globals RegisterA (zero ?)) l) in
     199    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc RegisterSPL)) l) in
     200    let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (OP2 … globals Add it it RegisterSPL) l) in
     201      〈add_graph globals original_label (sequential (ltl_params globals) globals (INT … globals RegisterA (bitvector_of_nat ? (stacksize globals int_fun))) l) graph, luniv〉.
     202
     203definition translate_statement:
     204  ∀globals: list ident. ertl_internal_function globals → ∀v: valuation.
     205    coloured_graph v → ltl_statement_graph globals → ertl_statement globals →
     206      label → ((ltl_statement_graph globals) × (universe LabelTag)) ≝
     207  λglobals: list ident.
     208  λint_fun.
     209  λvaluation.
     210  λcoloured_graph: coloured_graph valuation.
    216211  λgraph: ltl_statement_graph globals.
    217212  λstmt: ertl_statement globals.
     213  λoriginal_label: label.
    218214  match stmt with
    219   [ joint_st_sequential seq l ⇒
    220     let luniv ≝ ertl_if_luniverse globals int_fun in
     215  [ sequential seq l ⇒
     216    let luniv ≝ joint_if_luniverse globals (ertl_params globals) int_fun in
    221217    match seq with
    222     [ joint_instr_comment c ⇒
    223       〈joint_st_sequential ltl_params globals (joint_instr_comment … globals c) l, graph, luniv〉
    224     | joint_instr_cost_label cost_lbl ⇒
    225       〈joint_st_sequential … globals (joint_instr_cost_label … globals cost_lbl) l, graph, luniv〉
    226     | joint_instr_pop r ⇒
    227       let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun graph r l in
    228       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc hdw)) l) in
    229         〈joint_st_sequential … globals (joint_instr_pop ltl_params globals it) l, graph, luniv〉
    230     | joint_instr_push r ⇒
    231       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_push … globals it) l) in
    232       let int_fun ≝ set_luniverse globals int_fun luniv in
    233       let 〈l, graph, luniv〉 ≝ read globals int_fun graph r (λhdw. joint_st_sequential … globals (joint_instr_move … globals (to_acc hdw)) l) in
    234         〈joint_st_goto ltl_params globals l, graph, luniv〉
    235     | joint_instr_cond srcr lbl_true ⇒
    236       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_cond … globals it lbl_true) l) in
    237       let int_fun ≝ set_luniverse globals int_fun luniv in
    238       let 〈l, graph, luniv〉 ≝ read globals int_fun graph srcr (λhdw. joint_st_sequential … globals (joint_instr_move … globals (to_acc hdw)) l) in
    239         〈joint_st_goto ltl_params globals l, graph, luniv〉
    240     | joint_instr_call_id f ignore ⇒ 〈joint_st_sequential … globals (joint_instr_call_id … globals f ignore) l, graph, luniv〉
    241     | joint_instr_store addr1 addr2 srcr ⇒
    242       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_store … globals it it it) l) in
    243       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (to_acc RegisterST1)) l) in
    244       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc RegisterDPH)) l) in
    245       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (to_acc RegisterST0)) l) in
    246       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc RegisterDPL)) l) in
    247       let int_fun ≝ set_luniverse globals int_fun luniv in
    248       let 〈l, graph, luniv〉 ≝ read globals int_fun graph addr1 (λhdw. joint_st_sequential … globals (joint_instr_move … globals (to_acc hdw)) l) in
    249       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc RegisterST0)) l) in
    250       let int_fun ≝ set_luniverse globals int_fun luniv in
    251       let 〈l, graph, luniv〉 ≝ read globals int_fun graph addr2 (λhdw. joint_st_sequential … globals (joint_instr_move … globals (to_acc hdw)) l) in
    252       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc RegisterST1)) l) in
    253       let 〈l, graph, luniv〉 ≝ read globals int_fun graph srcr (λhdw. joint_st_sequential … globals (joint_instr_move … globals (to_acc hdw)) l) in
    254         〈joint_st_goto ltl_params globals l, graph, luniv〉
    255     | joint_instr_load destr addr1 addr2 ⇒
    256       let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun graph destr l in
    257       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc hdw)) l) in
    258       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_load … globals it it it) l) in
    259       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc RegisterDPH)) l) in
    260       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (to_acc RegisterST0)) l) in
    261       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc RegisterDPL)) l) in
    262       let int_fun ≝ set_luniverse globals int_fun luniv in
    263       let 〈l, graph, luniv〉 ≝ read globals int_fun graph addr1 (λhdw. joint_st_sequential … globals (joint_instr_move … globals (to_acc hdw)) l) in
    264       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc RegisterST0)) l) in
    265       let int_fun ≝ set_luniverse globals int_fun luniv in
    266       let 〈l, graph, luniv〉 ≝ read globals int_fun graph addr2 (λhdw. joint_st_sequential … globals (joint_instr_move … globals (to_acc hdw)) l) in
    267         〈joint_st_goto ltl_params globals l, graph, luniv〉
    268     | joint_instr_clear_carry ⇒ 〈joint_st_sequential … globals (joint_instr_clear_carry … globals) l, graph, luniv〉
    269     | joint_instr_set_carry ⇒ 〈joint_st_sequential … globals (joint_instr_set_carry … globals) l, graph, luniv〉
    270     | joint_instr_op2 op2 destr srcr ⇒
    271       let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun graph destr l in
    272       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc hdw)) l) in
    273       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_op2 … globals op2 it RegisterB) l) in
    274       let luniv ≝ set_luniverse globals int_fun luniv in
    275       let 〈l, graph, luniv〉 ≝ read globals int_fun graph destr (λhdw. joint_st_sequential … globals (joint_instr_move … globals (to_acc hdw)) l) in
    276       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc RegisterB)) l) in
    277       let luniv ≝ set_luniverse globals int_fun luniv in
    278       let 〈l, graph, luniv〉 ≝ read globals int_fun graph srcr (λhdw. joint_st_sequential … globals (joint_instr_move … globals (to_acc hdw)) l) in
    279         〈joint_st_goto ltl_params globals l, graph, luniv〉
    280     | joint_instr_op1 op1 acc_a ⇒
    281       let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun graph acc_a l in
    282       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc hdw)) l) in
    283       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_op1 … globals op1 it) l) in
    284       let int_fun ≝ set_luniverse globals int_fun luniv in
    285       let 〈l, graph, luniv〉 ≝ read globals int_fun graph acc_a (λhdw. joint_st_sequential … globals (joint_instr_move … globals (to_acc hdw)) l) in
    286         〈joint_st_goto ltl_params globals l, graph, luniv〉
    287     | joint_instr_int r i ⇒
    288       let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun graph r l in
    289         〈joint_st_sequential ltl_params globals (joint_instr_int … globals hdw i) l, graph, luniv〉
    290     | joint_instr_opaccs opaccs acc_a_reg acc_b_reg ⇒
    291       let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun graph acc_a_reg l in
    292       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc hdw)) l) in
    293       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_opaccs … globals opaccs it it) l) in
    294       let luniv ≝ set_luniverse globals int_fun luniv in
    295       let 〈l, graph, luniv〉 ≝ read globals int_fun graph acc_a_reg (λhdw. joint_st_sequential … globals (joint_instr_move … globals (to_acc hdw)) l) in
    296       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc RegisterB)) l) in
    297       let luniv ≝ set_luniverse globals int_fun luniv in
    298       let 〈l, graph, luniv〉 ≝ read globals int_fun graph acc_b_reg (λhdw. joint_st_sequential … globals (joint_instr_move … globals (to_acc hdw)) l) in
    299       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_goto … globals l) in
    300       let luniv ≝ set_luniverse globals int_fun luniv in
    301       let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun graph acc_b_reg l in
    302       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc hdw)) l) in
    303       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (to_acc RegisterB)) l) in
    304       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_opaccs … globals opaccs it it) l) in
    305       let luniv ≝ set_luniverse globals int_fun luniv in
    306       let 〈l, graph, luniv〉 ≝ read globals int_fun graph acc_a_reg (λhdw. joint_st_sequential … globals (joint_instr_move … globals (to_acc hdw)) l) in
    307       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc RegisterB)) l) in
    308       let luniv ≝ set_luniverse globals int_fun luniv in
    309       let 〈l, graph, luniv〉 ≝ read globals int_fun graph acc_b_reg (λhdw. joint_st_sequential … globals (joint_instr_move … globals (to_acc hdw)) l) in
    310         〈joint_st_goto ltl_params globals l, graph, luniv〉
    311     | joint_instr_move pair_regs ⇒
     218    [ COMMENT c ⇒
     219      〈add_graph globals original_label (sequential … (COMMENT … c) l) graph, luniv〉
     220    | COST_LABEL cost_lbl ⇒
     221      〈add_graph globals original_label (sequential … (COST_LABEL … cost_lbl) l) graph, luniv〉
     222    | POP r ⇒
     223      let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     224      let int_fun ≝ set_luniverse globals ? int_fun luniv in
     225      let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun valuation coloured_graph graph r l fresh_lbl in
     226      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc hdw)) l) in
     227        〈add_graph globals original_label (sequential ltl_params_ globals (POP … it) l) graph, luniv〉
     228    | PUSH r ⇒
     229      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (PUSH … globals it) l) in
     230      let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     231      let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     232      let int_fun ≝ set_luniverse globals ? int_fun luniv in
     233      let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph r (λhdw. sequential … (MOVE … (to_acc hdw)) l) fresh_lbl in
     234        〈add_graph globals original_label (GOTO … fresh_lbl) graph, luniv〉
     235    | COND srcr lbl_true ⇒
     236      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (COND … it lbl_true) l) in
     237      let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     238      let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     239      let int_fun' ≝ set_luniverse globals ? int_fun luniv in
     240      let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph srcr (λhdw. sequential … (MOVE … (to_acc hdw)) l) fresh_lbl in
     241        〈add_graph globals original_label (GOTO … fresh_lbl) graph, luniv〉
     242    | CALL_ID f ignore ignore' ⇒ 〈add_graph globals original_label (sequential … (CALL_ID … f ignore ignore') l) graph, luniv〉
     243    | STORE addr1 addr2 srcr ⇒
     244      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (STORE … it it it) l) in
     245      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (to_acc RegisterST1)) l) in
     246      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc RegisterDPH)) l) in
     247      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (to_acc RegisterST0)) l) in
     248      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc RegisterDPL)) l) in
     249      let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     250      let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     251      let int_fun ≝ set_luniverse globals ? int_fun luniv in
     252      let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph addr1 (λhdw. sequential … (MOVE … (to_acc hdw)) l) fresh_lbl in
     253      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc RegisterST0)) fresh_lbl) in
     254      let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     255      let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     256      let int_fun ≝ set_luniverse globals ? int_fun luniv in
     257      let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph addr2 (λhdw. sequential … (MOVE … (to_acc hdw)) l) fresh_lbl in
     258      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc RegisterST1)) fresh_lbl) in
     259      let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     260      let int_fun ≝ set_luniverse globals ? int_fun luniv in
     261      let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph srcr (λhdw. sequential … (MOVE … (to_acc hdw)) l) fresh_lbl in
     262        〈add_graph globals original_label (GOTO … l) graph, luniv〉
     263    | LOAD destr addr1 addr2 ⇒
     264      let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     265      let int_fun ≝ set_luniverse globals ? int_fun luniv in
     266      let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun valuation coloured_graph graph destr l fresh_lbl in
     267      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc hdw)) l) in
     268      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (LOAD … it it it) l) in
     269      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc RegisterDPH)) l) in
     270      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (to_acc RegisterST0)) l) in
     271      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc RegisterDPL)) l) in
     272      let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     273      let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     274      let int_fun ≝ set_luniverse globals ? int_fun luniv in
     275      let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph addr1 (λhdw. sequential … (MOVE … (to_acc hdw)) l) fresh_lbl in
     276      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc RegisterST0)) fresh_lbl) in
     277      let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     278      let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     279      let int_fun ≝ set_luniverse globals ? int_fun luniv in
     280      let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph addr2 (λhdw. sequential … (MOVE … (to_acc hdw)) l) fresh_lbl in
     281        〈add_graph globals original_label (GOTO … fresh_lbl) graph, luniv〉
     282    | CLEAR_CARRY ⇒ 〈add_graph globals original_label (sequential … (CLEAR_CARRY …) l) graph, luniv〉
     283    | SET_CARRY ⇒ 〈add_graph globals original_label (sequential … (SET_CARRY …) l) graph, luniv〉
     284    | OP2 op2 destr srcr1 srcr2 ⇒
     285      let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     286      let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     287      let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun valuation coloured_graph graph destr l fresh_lbl in
     288      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc hdw)) l) in
     289      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (OP2 … op2 it it RegisterB) l) in
     290      let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     291      let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     292      let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph srcr1 (λhdw. sequential … (MOVE … (to_acc hdw)) l) fresh_lbl in
     293      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc RegisterB)) fresh_lbl) in
     294      let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     295      let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     296      let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph srcr2 (λhdw. sequential … (MOVE … (to_acc hdw)) l) fresh_lbl in
     297        〈add_graph globals original_label (GOTO … l) graph, luniv〉
     298    | OP1 op1 destr srcr ⇒
     299      let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     300      let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     301      let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun valuation coloured_graph graph destr l fresh_lbl in
     302      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc hdw)) l) in
     303      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (OP1 … op1 it it) l) in
     304      let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     305      let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     306      let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     307      let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph srcr (λhdw. sequential … (MOVE … (to_acc hdw)) l) fresh_lbl in
     308        〈add_graph globals original_label (GOTO … l) graph, luniv〉
     309    | INT r i ⇒
     310      let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     311      let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     312      let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun valuation coloured_graph graph r l fresh_lbl in
     313        〈add_graph globals original_label (sequential ltl_params_ globals (INT … hdw i) l) graph, luniv〉
     314    | MOVE pair_regs ⇒
    312315      let regl ≝ \fst pair_regs in
    313316      let regr ≝ \snd pair_regs in
    314317      match regl with
    315318      [ pseudo p1  ⇒
    316         match regr with
    317         [ pseudo p2  ⇒ move globals int_fun graph (lookup p1) (lookup p2) l
    318         | hardware h ⇒ move globals int_fun graph (lookup p1) (decision_colour h) l
     319        match regr with 
     320        [ pseudo p2  ⇒ move globals int_fun graph (colouring valuation coloured_graph (inl … p1)) (colouring valuation coloured_graph (inl … p2)) l original_label
     321        | hardware h ⇒ move globals int_fun graph (colouring valuation coloured_graph (inl … p1)) (decision_colour h) l original_label
    319322        ]
    320323      | hardware h1 ⇒
    321324        match regr with
    322         [ pseudo p    ⇒ move globals int_fun graph (decision_colour h1) (lookup p) l
     325        [ pseudo p    ⇒ move globals int_fun graph (decision_colour h1) (colouring valuation coloured_graph (inl … p)) l original_label
    323326        | hardware h2 ⇒
    324           let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc h1)) l) in
    325             〈joint_st_sequential ltl_params globals (joint_instr_move ltl_params globals (to_acc h2)) l, graph, luniv〉
     327          let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc h1)) l) in
     328            〈add_graph globals original_label (sequential ltl_params_ … (MOVE … (to_acc h2)) l) graph, luniv〉
    326329        ]
    327330      ]
    328     | joint_instr_address lbl prf dpl dph ⇒
    329       let 〈hdw1, l, graph, luniv〉 ≝ write globals int_fun graph dph l in
    330       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc hdw1)) l) in
    331       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (to_acc RegisterDPH)) l) in
    332       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_address … globals lbl prf it it) l) in
    333       let int_fun ≝ set_luniverse globals int_fun luniv in
    334       let 〈hdw2, l, graph, luniv〉 ≝ write globals int_fun graph dpl l in
    335       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (from_acc hdw2)) l) in
    336       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (joint_st_sequential … globals (joint_instr_move … globals (to_acc RegisterDPL)) l) in
    337         〈joint_st_sequential ltl_params globals (joint_instr_address … globals lbl prf it it) l, graph, luniv〉
     331    | ADDRESS lbl prf dpl dph ⇒
     332      let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     333      let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     334      let 〈hdw1, l, graph, luniv〉 ≝ write globals int_fun valuation coloured_graph graph dph l fresh_lbl in
     335      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc hdw1)) l) in
     336      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (to_acc RegisterDPH)) l) in
     337      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (ADDRESS … globals lbl prf it it) l) in
     338      let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     339      let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     340      let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     341      let 〈hdw2, l, graph, luniv〉 ≝ write globals int_fun valuation coloured_graph graph dpl l fresh_lbl in
     342      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc hdw2)) l) in
     343      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (to_acc RegisterDPL)) l) in
     344        〈add_graph globals original_label (sequential ltl_params_ globals (ADDRESS … lbl prf it it) l) graph, luniv〉
     345    | extension ext ⇒
     346      match ext with
     347      [ ertl_st_ext_new_frame ⇒ newframe globals int_fun graph l original_label
     348      | ertl_st_ext_del_frame ⇒ delframe globals int_fun graph l original_label
     349      | ertl_st_ext_frame_size r ⇒
     350        let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     351        let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     352        let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun valuation coloured_graph graph r l fresh_lbl in
     353          〈add_graph globals original_label (sequential ltl_params_ globals (INT … hdw (bitvector_of_nat … (stacksize … int_fun))) l) graph, luniv〉
     354      ]
     355    | OPACCS opaccs dacc_a_reg dacc_b_reg sacc_a_reg sacc_b_reg ⇒
     356      let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     357      let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun valuation coloured_graph graph dacc_a_reg l fresh_lbl in
     358      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc hdw)) l) in
     359      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (OPACCS … opaccs it it it it) l) in
     360      let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     361      let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     362      let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     363      let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph sacc_a_reg (λhdw. sequential … globals (MOVE … globals (to_acc hdw)) l) fresh_lbl in
     364      let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc RegisterB)) fresh_lbl) in
     365      let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     366      let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
     367      let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
     368      let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph sacc_b_reg (λhdw. sequential … globals (MOVE … globals (to_acc hdw)) l) fresh_lbl in
     369        〈add_graph globals original_label (GOTO … globals fresh_lbl) graph, luniv〉
    338370    ]
    339   | joint_st_return ⇒ 〈joint_st_return … globals, graph, ertl_if_luniverse globals int_fun〉
    340   | joint_st_goto l ⇒ 〈joint_st_goto … globals l, graph, ertl_if_luniverse globals int_fun〉
    341   | joint_st_extension ext ⇒
    342     match ext with
    343     [ ertl_st_ext_new_frame l ⇒ newframe globals int_fun graph l
    344     | ertl_st_ext_del_frame l ⇒ delframe globals int_fun graph l
    345     | ertl_st_ext_frame_size r l ⇒
    346       let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun graph r l in
    347         〈joint_st_sequential … globals (joint_instr_int ltl_params globals hdw (bitvector_of_nat ? (stacksize globals int_fun))) l, graph, luniv〉
     371  | RETURN ⇒ 〈add_graph globals original_label (RETURN ltl_params_ globals) graph, joint_if_luniverse globals (ertl_params globals) int_fun〉
     372  | GOTO l ⇒ 〈add_graph globals original_label (GOTO ltl_params_ globals l) graph, joint_if_luniverse globals (ertl_params globals) int_fun〉
     373  ].
     374
     375lemma Sm_leq_n_m_leq_n:
     376  ∀m, n: nat.
     377    S m ≤ n → m ≤ n.
     378  #m #n /2/
     379qed.
     380
     381let rec fold_aux
     382  (a, b: Type[0]) (f: BitVector 16 → a → b → b) (seed: b) (n: nat)
     383    on n: n ≤ 16 → BitVectorTrie a n → BitVector (16 - n) → b ≝
     384  match n return λn: nat. n ≤ 16 → BitVectorTrie a n → BitVector (16 - n) → b with
     385  [ O    ⇒ λinvariant: 0 ≤ 16. λtrie: BitVectorTrie a 0. λpath: BitVector 16.
     386    match trie return λx: nat. λtrie': BitVectorTrie a x. ∀prf: x = 0. b with
     387    [ Leaf l      ⇒ λproof. f path l seed
     388    | Stub s      ⇒ λproof. seed
     389    | Node n' l r ⇒ λabsrd. ⊥
     390    ] (refl … 0)
     391  | S n' ⇒ λinvariant: S n' ≤ 16. λtrie: BitVectorTrie a (S n'). λpath: BitVector (16 - S n').
     392    match trie return λx: nat. λtrie': BitVectorTrie a x. ∀prf: x = S n'. b with
     393    [ Leaf l      ⇒ λabsrd. ⊥
     394    | Stub s      ⇒ λproof. seed
     395    | Node n'' l r ⇒ λproof.
     396        fold_aux a b f (fold_aux a b f seed n' ? (l⌈BitVectorTrie a n'' ↦ BitVectorTrie a n'⌉) ((false:::path)⌈S (16 - S n') ↦ 16 - n'⌉)) n' ? (r⌈BitVectorTrie a n'' ↦ BitVectorTrie a n'⌉) ((true:::path)⌈S (16 - S n') ↦ 16 - n'⌉)
     397    ] (refl … (S n'))
     398  ].
     399  [ 1, 2: destruct(absrd)
     400  | 3,8: >minus_S_S <minus_Sn_m // @le_S_S_to_le //
     401  | 4,7: destruct(proof) %
     402  | 5,6: @Sm_leq_n_m_leq_n // ]
     403qed.
     404
     405definition bvt_fold ≝
     406  λa, b: Type[0].
     407  λf: label → a → b → b.
     408  λtrie: BitVectorTrie a 16.
     409  λseed: b.
     410    let f' ≝ λbv: BitVector 16. λa. λb.
     411      f (an_identifier LabelTag bv) a b
     412    in
     413      fold_aux a b f' seed 16 ? trie [[]].
     414  //
     415qed.
     416
     417definition graph_fold ≝
     418  λglobals.
     419  λb : Type[0].
     420  λf    : label → ertl_statement globals → b → b.
     421  λgraph: graph (ertl_statement globals).
     422  λseed : b.
     423  match graph with
     424  [ an_id_map tree ⇒ bvt_fold (ertl_statement globals) b f tree seed
     425  ]. 
     426
     427definition translate_internal: ∀globals: list ident.
     428  ertl_internal_function globals → ltl_internal_function globals ≝
     429  λglobals: list ident.
     430  λint_fun: ertl_internal_function globals.
     431  let graph ≝ (empty_map … : ltl_statement_graph globals) in
     432  let valuation ≝ analyse globals int_fun in
     433  let coloured_graph ≝ build valuation in
     434  let 〈graph, luniv〉 ≝ graph_fold globals ((ltl_statement_graph globals) × (universe LabelTag)) (λlabel: label. λstmt: ertl_statement globals. λgraph_luniv: (? × (universe LabelTag)).
     435    let 〈graph, luniv〉 ≝ graph_luniv in
     436      match eliminable globals (valuation label) stmt with
     437      [ Some successor ⇒ 〈add_graph globals label (GOTO … successor) graph, luniv〉
     438      | None           ⇒
     439        translate_statement globals int_fun valuation coloured_graph graph stmt label
     440      ]) (joint_if_code globals (ertl_params globals) int_fun) 〈graph, joint_if_luniverse … int_fun〉
     441  in
     442    match joint_if_entry … int_fun with
     443    [ dp entry_label entry_label_prf ⇒
     444      match joint_if_exit … int_fun with
     445      [ dp exit_label exit_label_prf ⇒
     446          mk_joint_internal_function globals (ltl_params globals)
     447            luniv (joint_if_runiverse … int_fun)
     448              it it it (joint_if_stacksize … int_fun)
     449                graph ? ?
     450      ]
     451    ].
     452  [1: %
     453    [1: @entry_label
     454    |2: cases daemon (* XXX *)
    348455    ]
    349   ].
    350 
    351 definition translate_internal ≝
    352   λglobals: list ident.
    353   λf.
    354   λint_fun: ertl_internal_function.
    355   let lookup ≝ λr.
    356     match lookup r with
    357     | colour_spill ->
    358         ERTLToLTLI.Spill (Interference.Vertex.Map.find (Interference.lookup H.graph r) S.coloring)
    359     | colour_colour color ->
    360         ERTLToLTLI.Color color
    361   in
    362   let locals ≝ colour_locals + (ertl_if_stacksize int_fun) in
    363   let stacksize ≝ (ertl_if_params int_fun) + locals in
    364     mk_ltl_internal_function
    365       globals
    366       (ertl_if_luniverse int_fun)
    367       (ertl_if_runiverse int_fun)
    368       stacksize.
    369 
    370   let () =
    371     Label.Map.iter (fun label stmt ->
    372       let stmt =
    373         match Liveness.eliminable (G.liveafter label) stmt with
    374         | Some successor ->
    375             LTL.St_skip successor
    376         | None ->
    377             I.translate_statement stmt
    378       in
    379       graph := Label.Map.add label stmt !graph
    380     ) int_fun.ERTL.f_graph
    381   in
    382 
    383 definition translate_funct ≝
    384   λname_def.
    385   let 〈name, def〉 ≝ name_def in
    386   let def' ≝
    387     match def with
    388     [ Internal def ⇒ Internal ? (translate_internal name def)
    389     | External def ⇒ External ? def
     456  |2: %
     457    [1: @exit_label
     458    |2: cases daemon (* XXX *)
    390459    ]
    391   in
    392     〈name, def'〉.
    393 
    394 definition translate ≝
    395   λp.
    396   let functs' ≝ map ? ? translate_funct (ertl_pr_functs p) in
    397     mk_ltl_program (ertl_pr_globals p) functs' (ertl_pr_main p).
     460  ]
     461qed.
     462
     463definition ertl_to_ltl: ertl_program → ltl_program ≝
     464  λp.transform_program … p (transf_fundef … (translate_internal …)).
  • Deliverables/D3.3/id-lookup-branch/ERTL/liveness.ma

    r1197 r1311  
    11include "ASM/Util.ma".
    22include "ERTL/ERTL.ma".
    3 
    4 definition list_set_union ≝
    5   λA: Type[0].
    6   λeq_a: A → A → bool.
    7   λl: list A.
    8   λr: list A.
    9     nub_by A eq_a (l @ r).
    10 
    11 definition list_set_add ≝
    12   λA: Type[0].
    13   λeq_a: A → A → bool.
    14   λa: A.
    15   λs: list A.
    16     nub_by A eq_a (a :: s).
    17 
    18 definition list_set_diff ≝
    19   λA: Type[0].
    20   λeq_a: A → A → bool.
    21   λl: list A.
    22   λr: list A.
    23     filter A (λx. member A eq_a x r) l.
    24 
    25 definition list_set_equal ≝
    26   λA: Type[0].
    27   λeq_a: A → A → bool.
    28   λl: list A.
    29   λr: list A.
    30     foldr ? ? andb true (map ? ? (λx. member A eq_a x r) l).
    31 
    32 definition list_set_member ≝ member.
    33 
    34 definition list_set_fold ≝ foldr.
     3include "utilities/adt/set_adt.ma".
    354
    365definition statement_successors ≝
     
    387  λs: ertl_statement globals.
    398  match s with
    40   [ joint_st_sequential seq l ⇒
    41     match seq with
    42     [ joint_instr_cond acc_a_reg lbl_true ⇒
    43         list_set_add ? (eq_identifier ?) lbl_true [ l ]
    44     | _ ⇒ [ l ]
    45     ]
    46   | joint_st_extension ext ⇒
    47     match ext with
    48     [ ertl_st_ext_new_frame l ⇒ [ l ]
    49     | ertl_st_ext_del_frame l ⇒ [ l ]
    50     | ertl_st_ext_frame_size r l ⇒ [ l ]
    51     ]
    52   | joint_st_goto l ⇒ [ l ]
    53   | joint_st_return ⇒ [ ]
    54   ].
    55 
    56 definition register_lattice ≝ (list register) × (list Register).
     9  [ sequential seq l ⇒
     10    match seq with
     11    [ COND acc_a_reg lbl_true ⇒
     12        set_insert … lbl_true (set_singleton … l)
     13    | _ ⇒ set_singleton … l ]
     14  | GOTO l ⇒ set_singleton … l
     15  | RETURN ⇒ set_empty ?
     16  ].
     17
     18definition register_lattice ≝ (set register) × (set Register).
    5719definition lattice_property ≝ register_lattice.
    58 definition lattice_bottom: register_lattice ≝ 〈[ ], [ ]〉.
     20definition lattice_bottom: register_lattice ≝ 〈set_empty register, set_empty Register〉.
    5921definition lattice_psingleton: register → register_lattice ≝
    6022  λr.
    61     〈[ r ], [ ]〉.
     23    〈set_singleton … r, set_empty …〉.
    6224definition lattice_hsingleton: Register → register_lattice ≝
    6325  λr.
    64     〈[ ], [ r ]〉.
     26    〈set_empty …, set_singleton … r〉.
    6527
    6628definition lattice_join: register_lattice → register_lattice → register_lattice ≝
     
    6931  let 〈lp, lh〉 ≝ left in
    7032  let 〈rp, rh〉 ≝ right in
    71     〈list_set_union ? (eq_identifier ?) lp rp, list_set_union ? eq_Register lh rh〉.
     33    〈set_union … lp rp, set_union … lh rh〉.
    7234
    7335definition lattice_diff: register_lattice → register_lattice → register_lattice ≝
     
    7638  let 〈lp, lh〉 ≝ left in
    7739  let 〈rp, rh〉 ≝ right in
    78     〈list_set_diff ? (eq_identifier ?) lp rp, list_set_diff ? eq_Register lh rh〉.
     40    〈set_diff … lp rp, set_diff … lh rh〉.
    7941
    8042definition lattice_equal: register_lattice → register_lattice → bool ≝
     
    8345  let 〈lp, lh〉 ≝ left in
    8446  let 〈rp, rh〉 ≝ right in
    85     andb (list_set_equal ? (eq_identifier ?) lp rp) (list_set_equal ? eq_Register lh rh).
     47    andb (set_equal … (eq_identifier …) lp rp) (set_equal … eq_Register lh rh).
    8648
    8749definition lattice_is_maximal: register_lattice → bool ≝ λl. false.
     
    10264definition property ≝
    10365  mk_lattice_property_sig
    104     ((list register) × (list Register))
     66    ((set register) × (set Register))
    10567    lattice_property
    10668    lattice_bottom
     
    11678  λs: ertl_statement globals.
    11779  match s with
    118   [ joint_st_sequential seq l ⇒
    119     match seq with
    120     [ joint_instr_op2 op2 r _ ⇒
     80  [ sequential seq l ⇒
     81    match seq with
     82    [ OP2 op2 r1 r2 _ ⇒
    12183      match op2 with
    122       [ Add ⇒ lattice_join (lattice_hsingleton RegisterCarry) (lattice_psingleton r)
    123       | Addc ⇒ lattice_join (lattice_hsingleton RegisterCarry) (lattice_psingleton r)
    124       | Sub ⇒ lattice_join (lattice_hsingleton RegisterCarry) (lattice_psingleton r)
    125       | _ ⇒ lattice_psingleton r
    126       ]
    127     | joint_instr_clear_carry ⇒ lattice_hsingleton RegisterCarry
    128     | joint_instr_set_carry ⇒ lattice_hsingleton RegisterCarry
    129     | joint_instr_opaccs opaccs r1 r2 ⇒ lattice_join (lattice_psingleton r1) (lattice_psingleton r2)
    130     | joint_instr_op1 op1 r ⇒ lattice_psingleton r
    131     | joint_instr_pop r ⇒ lattice_psingleton r
    132     | joint_instr_int r _ ⇒ lattice_psingleton r
    133     | joint_instr_address _ _ r1 r2 ⇒ lattice_join (lattice_psingleton r1) (lattice_psingleton r2)
    134     | joint_instr_load r _ _ ⇒ lattice_psingleton r
     84      [ Add ⇒ lattice_join (lattice_hsingleton RegisterCarry) (lattice_psingleton r1)
     85      | Addc ⇒ lattice_join (lattice_hsingleton RegisterCarry) (lattice_psingleton r1)
     86      | Sub ⇒ lattice_join (lattice_hsingleton RegisterCarry)  (lattice_psingleton r1)
     87      | _ ⇒ lattice_psingleton r1
     88      ]
     89    | CLEAR_CARRY ⇒ lattice_hsingleton RegisterCarry
     90    | SET_CARRY ⇒ lattice_hsingleton RegisterCarry
     91    | OPACCS opaccs dr1 dr2 sr1 sr2 ⇒
     92       lattice_join (lattice_psingleton dr1) (lattice_psingleton dr2)
     93    | OP1 op1 r1 r2 ⇒ lattice_join (lattice_psingleton r1) (lattice_psingleton r2)
     94    | POP r ⇒ lattice_psingleton r
     95    | INT r _ ⇒ lattice_psingleton r
     96    | ADDRESS _ _ r1 r2 ⇒ lattice_join (lattice_psingleton r1) (lattice_psingleton r2)
     97    | LOAD r _ _ ⇒ lattice_psingleton r
    13598    (* Potentially destroys all caller-save hardware registers. *)
    136     | joint_instr_call_id _ _ ⇒ 〈[ ], RegisterCallerSaved〉
    137     | joint_instr_comment c ⇒ lattice_bottom
    138     | joint_instr_cond r lbl_true ⇒ lattice_bottom
    139     | joint_instr_store acc_a dpl dph ⇒ lattice_bottom
    140     | joint_instr_cost_label clabel ⇒ lattice_bottom
    141     | joint_instr_push r ⇒ lattice_bottom
    142     | joint_instr_move pair_reg ⇒
     99    | CALL_ID id _ _ ⇒ 〈set_empty …, set_from_list … RegisterCallerSaved〉
     100    | COMMENT c ⇒ lattice_bottom
     101    | COND r lbl_true ⇒ lattice_bottom
     102    | STORE acc_a dpl dph ⇒ lattice_bottom
     103    | COST_LABEL clabel ⇒ lattice_bottom
     104    | PUSH r ⇒ lattice_bottom
     105    | MOVE pair_reg ⇒
    143106      (* first register relevant only *)
    144107      let r1 ≝ \fst pair_reg in
     
    147110      | hardware h ⇒ lattice_hsingleton h
    148111      ]
    149     ]
    150   | joint_st_return ⇒ lattice_bottom
    151   | joint_st_extension ext ⇒
    152     match ext with
    153     [ ertl_st_ext_new_frame l ⇒ lattice_join (lattice_hsingleton RegisterSPL) (lattice_hsingleton RegisterSPH)
    154     | ertl_st_ext_del_frame l ⇒ lattice_join (lattice_hsingleton RegisterSPL) (lattice_hsingleton RegisterSPH)
    155     | ertl_st_ext_frame_size r l ⇒ lattice_psingleton r
    156     ]
    157   | joint_st_goto l ⇒ lattice_bottom
    158   ].
    159 
    160 definition list_set_of_list ≝
    161   λrl.
    162     foldr ? ? (list_set_add Register eq_Register) rl [ ].
    163 
    164 definition list_set_of_list2 ≝
    165   let f ≝ λset. λr. list_set_add Register eq_Register r set in
    166     foldl ? ? f [ ].
    167 
    168 definition ret_regs ≝ list_set_of_list RegisterRets.
     112    | extension ext ⇒
     113      match ext with
     114      [ ertl_st_ext_new_frame ⇒ lattice_join (lattice_hsingleton RegisterSPL) (lattice_hsingleton RegisterSPH)
     115      | ertl_st_ext_del_frame ⇒ lattice_join (lattice_hsingleton RegisterSPL) (lattice_hsingleton RegisterSPH)
     116      | ertl_st_ext_frame_size r ⇒ lattice_psingleton r]]
     117  | RETURN ⇒ lattice_bottom
     118  | GOTO l ⇒ lattice_bottom
     119  ].
     120
     121definition ret_regs ≝ set_from_list … RegisterRets.
    169122
    170123definition used ≝
     
    172125  λs: ertl_statement globals.
    173126  match s with
    174   [ joint_st_sequential seq l ⇒
    175     match seq with
    176     [ joint_instr_op2 op2 acc_a r
     127  [ sequential seq l ⇒
     128    match seq with
     129    [ OP2 op2 acc_a r1 r2
    177130      match op2 with
    178131      [ Addc ⇒
    179         lattice_join (lattice_join (lattice_psingleton acc_a) (lattice_psingleton r)) (lattice_hsingleton RegisterCarry)
    180       | _ ⇒ lattice_join (lattice_psingleton acc_a) (lattice_psingleton r)
    181       ]
    182     | joint_instr_clear_carry ⇒ lattice_bottom
    183     | joint_instr_set_carry ⇒ lattice_bottom
     132        lattice_join (lattice_join (lattice_psingleton r1) (lattice_psingleton r2)) (lattice_hsingleton RegisterCarry)
     133      | _ ⇒ lattice_join (lattice_psingleton r1) (lattice_psingleton r2)
     134      ]
     135    | CLEAR_CARRY ⇒ lattice_bottom
     136    | SET_CARRY ⇒ lattice_bottom
    184137    (* acc_a and acc_b *)
    185     | joint_instr_opaccs opaccs r1 r2 ⇒ lattice_join (lattice_psingleton r1) (lattice_psingleton r2)
    186     | joint_instr_op1 op1 r ⇒ lattice_psingleton r
    187     | joint_instr_pop r ⇒ lattice_bottom
    188     | joint_instr_int r _ ⇒ lattice_bottom
    189     | joint_instr_address _ _ r1 r2 ⇒ lattice_bottom
    190     | joint_instr_load acc_a dpl dph ⇒ lattice_join (lattice_psingleton dpl) (lattice_psingleton dph)
     138    | OPACCS opaccs dr1 dr2 sr1 sr2 ⇒
     139       lattice_join (lattice_psingleton sr1) (lattice_psingleton sr2)
     140    | OP1 op1 r1 r2 ⇒ lattice_psingleton r2
     141    | POP r ⇒ lattice_bottom
     142    | INT r _ ⇒ lattice_bottom
     143    | ADDRESS _ _ r1 r2 ⇒ lattice_bottom
     144    | LOAD acc_a dpl dph ⇒ lattice_join (lattice_psingleton dpl) (lattice_psingleton dph)
    191145    (* Reads the hardware registers that are used to pass parameters. *)
    192     | joint_instr_call_id _ nparams ⇒ 〈[ ], list_set_of_list (prefix ? nparams RegisterParams)〉
    193     | joint_instr_comment c ⇒ lattice_bottom
    194     | joint_instr_cond r lbl_true ⇒ lattice_psingleton r
    195     | joint_instr_store acc_a dpl dph ⇒
     146    | CALL_ID _ nparams _ ⇒ 〈set_empty …, set_from_list … (prefix ? nparams RegisterParams)〉
     147    | COMMENT c ⇒ lattice_bottom
     148    | COND r lbl_true ⇒ lattice_psingleton r
     149    | STORE acc_a dpl dph ⇒
    196150      lattice_join (lattice_join (lattice_psingleton acc_a) (lattice_psingleton dpl)) (lattice_psingleton dph)
    197     | joint_instr_cost_label clabel ⇒ lattice_bottom
    198     | joint_instr_push r ⇒ lattice_psingleton r
    199     | joint_instr_move pair_reg ⇒
     151    | COST_LABEL clabel ⇒ lattice_bottom
     152    | PUSH r ⇒ lattice_psingleton r
     153    | MOVE pair_reg ⇒
    200154      (* only second reg in pair relevant *)
    201155      let r2 ≝ \snd pair_reg in
     
    204158      | hardware h ⇒ lattice_hsingleton h
    205159      ]
    206     ]
    207   | joint_st_return ⇒ 〈[ ], list_set_union ? eq_Register RegisterCalleeSaved ret_regs〉
    208   | joint_st_goto l ⇒ lattice_bottom
    209   | joint_st_extension ext ⇒
     160  | extension ext ⇒
    210161    match ext with
    211     [ ertl_st_ext_new_frame l ⇒ lattice_join (lattice_hsingleton RegisterSPL) (lattice_hsingleton RegisterSPH)
    212     | ertl_st_ext_del_frame l ⇒ lattice_join (lattice_hsingleton RegisterSPL) (lattice_hsingleton RegisterSPH)
    213     | ertl_st_ext_frame_size r l ⇒ lattice_bottom
    214     ]
     162    [ ertl_st_ext_new_frame ⇒ lattice_join (lattice_hsingleton RegisterSPL) (lattice_hsingleton RegisterSPH)
     163    | ertl_st_ext_del_frame ⇒ lattice_join (lattice_hsingleton RegisterSPL) (lattice_hsingleton RegisterSPH)
     164    | ertl_st_ext_frame_size r ⇒ lattice_bottom]]
     165  | RETURN ⇒ 〈set_empty …, set_union … (set_from_list … RegisterCalleeSaved) ret_regs〉
     166  | GOTO l ⇒ lattice_bottom
    215167  ].
    216168
     
    221173  let 〈pliveafter, hliveafter〉 ≝ l in
    222174  match s with
    223   [ joint_st_sequential seq l ⇒
    224     match seq with
    225     [ joint_instr_op2 op2 acc_a r
    226       if list_set_member register (eq_identifier ?) acc_a pliveafter ∨
    227          list_set_member Register eq_Register RegisterCarry hliveafter then
    228         None ?
    229       else
    230         Some ? l
    231     | joint_instr_clear_carry ⇒ None ?
    232     | joint_instr_set_carry ⇒ None ?
    233     | joint_instr_opaccs opaccs r1 r2 ⇒
    234       if list_set_member register (eq_identifier ?) r1 pliveafter ∨
    235          list_set_member register (eq_identifier ?) r2 pliveafter ∨
    236          list_set_member Register eq_Register RegisterCarry hliveafter then
    237         None ?
    238       else
    239         Some ? l
    240     | joint_instr_op1 op1 r
    241       if list_set_member register (eq_identifier ?) r pliveafter ∨
    242          list_set_member Register eq_Register RegisterCarry hliveafter then
    243         None ?
    244       else
    245         Some ? l
    246     | joint_instr_pop r ⇒ None ?
    247     | joint_instr_int r _ ⇒
    248       if list_set_member register (eq_identifier ?) r pliveafter ∨
    249          list_set_member Register eq_Register RegisterCarry hliveafter then
    250         None ?
    251       else
    252         Some ? l
    253     | joint_instr_address _ _ r1 r2 ⇒
    254       if list_set_member register (eq_identifier ?) r1 pliveafter ∨
    255          list_set_member register (eq_identifier ?) r2 pliveafter ∨
    256          list_set_member Register eq_Register RegisterCarry hliveafter then
    257         None ?
    258       else
    259         Some ? l
    260     | joint_instr_load acc_a dpl dph ⇒
    261       if list_set_member register (eq_identifier ?) acc_a pliveafter ∨
    262          list_set_member Register eq_Register RegisterCarry hliveafter then
    263         None ?
    264       else
    265         Some ? l
    266     | joint_instr_call_id _ nparams ⇒ None ?
    267     | joint_instr_comment c ⇒ None ?
    268     | joint_instr_cond r lbl_true ⇒ None ?
    269     | joint_instr_store acc_a dpl dph ⇒ None ?
    270     | joint_instr_cost_label clabel ⇒ None ?
    271     | joint_instr_push r ⇒ None ?
    272     | joint_instr_move pair_reg ⇒
     175  [ sequential seq l ⇒
     176    match seq with
     177    [ OP2 op2 r1 r2 r3
     178      if set_member … (eq_identifier …) r1 pliveafter ∨
     179         set_member … eq_Register RegisterCarry hliveafter then
     180        None ?
     181      else
     182        Some ? l
     183    | CLEAR_CARRY ⇒ None ?
     184    | SET_CARRY ⇒ None ?
     185    | OPACCS opaccs dr1 dr2 sr1 sr2 ⇒
     186      if set_member … (eq_identifier …) dr1 pliveafter ∨
     187         set_member … (eq_identifier …) dr2 pliveafter ∨
     188         set_member … eq_Register RegisterCarry hliveafter then
     189        None ?
     190      else
     191        Some ? l
     192    | OP1 op1 r1 r2
     193      if set_member … (eq_identifier …) r1 pliveafter ∨
     194         set_member … eq_Register RegisterCarry hliveafter then
     195        None ?
     196      else
     197        Some ? l
     198    | POP r ⇒ None ?
     199    | INT r _ ⇒
     200      if set_member … (eq_identifier …) r pliveafter ∨
     201         set_member … eq_Register RegisterCarry hliveafter then
     202        None ?
     203      else
     204        Some ? l
     205    | ADDRESS _ _ r1 r2 ⇒
     206      if set_member … (eq_identifier …) r1 pliveafter ∨
     207         set_member … (eq_identifier …) r2 pliveafter ∨
     208         set_member … eq_Register RegisterCarry hliveafter then
     209        None ?
     210      else
     211        Some ? l
     212    | LOAD acc_a dpl dph ⇒
     213      if set_member ? (eq_identifier …) acc_a pliveafter ∨
     214         set_member … eq_Register RegisterCarry hliveafter then
     215        None ?
     216      else
     217        Some ? l
     218    | CALL_ID _ nparams _ ⇒ None ?
     219    | COMMENT c ⇒ None ?
     220    | COND r lbl_true ⇒ None ?
     221    | STORE acc_a dpl dph ⇒ None ?
     222    | COST_LABEL clabel ⇒ None ?
     223    | PUSH r ⇒ None ?
     224    | MOVE pair_reg ⇒
    273225      let r1 ≝ \fst pair_reg in
    274226      let r2 ≝ \snd pair_reg in
    275227      match r1 with
    276228      [ pseudo p1 ⇒
    277         if list_set_member register (eq_identifier ?) p1 pliveafter ∨
    278            list_set_member Register eq_Register RegisterCarry hliveafter then
     229        if set_member … (eq_identifier …) p1 pliveafter ∨
     230           set_member … eq_Register RegisterCarry hliveafter then
    279231          None ?
    280232        else
    281233          Some ? l
    282234      | hardware h1 ⇒
    283         if list_set_member Register eq_Register h1 hliveafter then
     235        if set_member … eq_Register h1 hliveafter then
    284236          None ?
    285237        else
    286           Some ? l
    287       ]
    288     ]
    289   | joint_st_goto l ⇒ None ?
    290   | joint_st_return ⇒ None ?
    291   | joint_st_extension ext ⇒
    292     match ext with
    293     [ ertl_st_ext_new_frame l ⇒ None ?
    294     | ertl_st_ext_del_frame l ⇒ None ?
    295     | ertl_st_ext_frame_size r l ⇒
    296       if list_set_member register (eq_identifier ?) r pliveafter ∨
    297         list_set_member Register eq_Register RegisterCarry hliveafter then
    298         None ?
    299       else
    300         Some ? l
    301     ]
     238          Some ? l]
     239    | extension ext ⇒
     240      match ext with
     241      [ ertl_st_ext_new_frame ⇒ None ?
     242      | ertl_st_ext_del_frame ⇒ None ?
     243      | ertl_st_ext_frame_size r ⇒
     244        if set_member ? (eq_identifier RegisterTag) r pliveafter ∨
     245           set_member ? eq_Register RegisterCarry hliveafter then
     246          None ?
     247        else
     248          Some ? l]]
     249  | GOTO l ⇒ None ?
     250  | RETURN ⇒ None ?
    302251  ].
    303252
     
    319268definition livebefore ≝
    320269  λglobals: list ident.
    321   λint_fun.
     270  λint_fun: ertl_internal_function globals.
    322271  λlabel.
    323272  λliveafter: valuation.
    324   match lookup ? ? (ertl_if_graph globals int_fun) label with
     273  match lookup … (joint_if_code … int_fun) label with
    325274  [ None      ⇒ ?
    326275  | Some stmt ⇒ statement_semantics globals stmt (liveafter label)
     
    330279
    331280definition liveafter ≝
    332   λglobals.
    333   λint_fun.
    334   λlivebefore.
     281  λglobals: list ident.
     282  λint_fun: ertl_internal_function globals.
     283  λlivebefore: label → ?.
    335284  λlabel.
    336285  λliveafter: valuation.
    337   match lookup … (ertl_if_graph globals int_fun) label with
     286  match lookup … (joint_if_code … int_fun) label with
    338287  [ None      ⇒ ?
    339   | Some stmt ⇒ list_set_fold … (λsuccessor. λaccu: register_lattice.
     288  | Some stmt ⇒ set_fold ? ? (λsuccessor. λaccu: register_lattice.
    340289      lattice_join (livebefore successor liveafter) accu)
    341       lattice_bottom (statement_successors globals stmt)
     290      (statement_successors globals stmt) lattice_bottom
    342291  ].
    343292  cases not_implemented (* XXX *)
  • Deliverables/D3.3/id-lookup-branch/ERTL/semantics.ma

    r1197 r1311  
    4949axiom hwreg_store : Register → val → mRegisterMap → res mRegisterMap.
    5050
    51 definition genv ≝ λglobals. (genv_t Genv) (fundef (ertl_internal_function globals)).
     51definition genv ≝ λglobals. (genv_t Genv) (fundef (joint_internal_function globals … (ertl_sem_params_ globals))).
    5252
    5353(* CSC: frame reduced to this *)
     
    139139
    140140axiom fetch_statement: ∀globals: list ident. state → res (ertl_statement globals).
    141 axiom fetch_function: ∀globals: list ident. state → res (ertl_internal_function globals).
     141axiom fetch_function: ∀globals: list ident. state → res (joint_internal_function globals … (ertl_sem_params_ globals)).
    142142
    143143definition init_locals : list register → register_env val ≝
     
    191191  (* CSC: monadic notation missing here *)
    192192    bind ?? (fetch_function globals st) (λf.
    193     OK ? (ertl_if_stacksize globals f)).
     193    OK ? (joint_if_stacksize globals … f)).
    194194
    195195definition get_hwsp : state → res address ≝
  • Deliverables/D3.3/id-lookup-branch/ERTL/spill.ma

    r1153 r1311  
    11include "common/AST.ma".
    2 include "utilities/Interference.ma".
     2include "ERTL/Interference.ma".
    33
    44definition decision ≝ Immediate.
  • Deliverables/D3.3/id-lookup-branch/LIN/LIN.ma

    r1197 r1311  
    11include "joint/Joint.ma".
     2include "utilities/lists.ma".
    23
    3 definition lin_params: params ≝
    4  mk_params
    5    unit unit unit unit registers_move Register
    6      unit unit unit unit.
     4definition lin_params__: params__ ≝
     5 mk_params__ unit unit unit unit registers_move Register nat unit False.
     6definition lin_params_ : params_ ≝ mk_params_ lin_params__ unit.
     7definition lin_params0 : params0 ≝ mk_params0 lin_params__ unit unit.
     8definition lin_params1 : params1 ≝ mk_params1 lin_params0 unit.
    79
    8 definition pre_lin_statement ≝
    9  λglobals: list ident. joint_statement lin_params globals.
    10 
    11 definition lin_statement ≝
    12   λglobals.
    13     option ident × (pre_lin_statement globals).
     10definition pre_lin_statement ≝ joint_statement lin_params_.
    1411
    1512definition well_formed_P ≝
     
    2118      match \fst hd with
    2219      [ Some lbl ⇒ False
    23       | None ⇒ True
    24       ]
    25     ].
    26    
    27 inductive lin_function_definition (globals: list ident): Type[0] ≝
    28   lin_fu_internal: ∀code: list (lin_statement globals). well_formed_P ? ? code → lin_function_definition globals
    29 | lin_fu_external: external_function → lin_function_definition globals.
     20      | None ⇒ True]].
    3021
    31 record lin_program: Type[0] ≝
    32 {
    33   lin_pr_vars: list (ident × nat);
    34   lin_pr_funcs: list (ident × (lin_function_definition (map ? ? (fst ? ?) lin_pr_vars)));
    35   lin_pr_main: option ident
    36 }.
     22definition lin_statement ≝ λglobals.(option label) × (pre_lin_statement globals).
     23
     24definition lin_params: ∀globals. params globals ≝
     25 λglobals.
     26  mk_params globals unit lin_params1 (Σcode:list (lin_statement globals). well_formed_P … code)
     27   (λcode:Σcode.?. λl.
     28    find ?? (λs. let 〈l',x〉 ≝ s in
     29     match l' with [ None ⇒ None … | Some l'' ⇒ if eq_identifier … l l'' then Some … x else None ?]) code).
     30
     31definition lin_function ≝ λglobals. joint_function … (lin_params globals).
     32
     33definition lin_program ≝ joint_program lin_params.
  • Deliverables/D3.3/id-lookup-branch/LIN/LINToASM.ma

    r1197 r1311  
    11include "ASM/Util.ma".
    22include "utilities/BitVectorTrieSet.ma".
    3 include "utilities/IdentifierTools.ma".
    43include "LIN/LIN.ma".
    5  
     4
    65let rec association (i: ident) (l: list (ident × nat))
    76                    on l: member i (eq_identifier ?) (map ? ? (fst ? ?) l) → nat ≝
     
    3231  let generated ≝
    3332    match instr with
    34     [ joint_st_sequential instr' _ ⇒
     33    [ sequential instr' _ ⇒
    3534      match instr' with
    36       [ joint_instr_cost_label lbl ⇒ set_insert ? (word_of_identifier ? lbl) (set_empty ?)
    37       | joint_instr_cond acc_a_reg lbl ⇒ set_insert ? (word_of_identifier ? lbl) (set_empty ?)
     35      [ COST_LABEL lbl ⇒ set_insert ? (word_of_identifier ? lbl) (set_empty ?)
     36      | COND acc_a_reg lbl ⇒ set_insert ? (word_of_identifier ? lbl) (set_empty ?)
    3837      | _ ⇒ set_empty ?
    3938      ]
    40     | joint_st_return ⇒ set_empty ?
    41     | joint_st_goto lbl ⇒ set_insert ? (word_of_identifier ? lbl) (set_empty ?)
    42     | joint_st_extension _ ⇒ set_empty ?
    43     ]
     39    | RETURN ⇒ set_empty ?
     40    | GOTO lbl ⇒ set_insert ? (word_of_identifier ? lbl) (set_empty ?) ]
    4441  in
    4542  match label with
     
    5451    set_union ? labels (statement_labels globals statement).
    5552
     53
    5654(* dpm: A = Identifier *)
    5755definition function_labels: ∀A. ∀globals. ∀f. BitVectorTrieSet ? ≝
    5856  λA: Type[0].
    5957  λglobals: list ident.
    60   λf: A × (lin_function_definition globals).
     58  λf: A × (lin_function globals).
    6159  let 〈ignore, fun_def〉 ≝ f in
    6260  match fun_def return λ_. BitVectorTrieSet ? with
    63   [ lin_fu_internal stmts proof
    64       foldl ? ? (function_labels_internal globals) (set_empty ?) stmts
    65   | lin_fu_external _ ⇒ set_empty ?
     61  [ Internal stmts
     62      foldl ? ? (function_labels_internal globals) (set_empty ?) (pi1 … (joint_if_code ?? stmts))
     63  | External _ ⇒ set_empty ?
    6664  ].
    6765 
     
    7068  λglobals: list ident.
    7169  λlabels: BitVectorTrieSet ?.
    72   λfunct: A × (lin_function_definition globals).
     70  λfunct: A × (lin_function globals).
    7371    set_union ? labels (function_labels ? globals funct).
    74    
     72
     73(* CSC: here we are silently throwing away the region information *)
    7574definition program_labels ≝
    76   λprogram.
    77     foldl ? ? (program_labels_internal ? (map ? ? (fst ? ?) (lin_pr_vars program)))
    78               (set_empty ?) (lin_pr_funcs program).
    79     
     75 λprogram: lin_program.
     76    foldl … (program_labels_internal … (map … (λx. fst … (fst … x)) (prog_vars … program)))
     77              (set_empty …) (prog_funct … program).
     78 
    8079definition data_of_int ≝ λbv. DATA bv.
    8180definition data16_of_int ≝ λbv. DATA16 (bitvector_of_nat 16 bv).
    8281definition accumulator_address ≝ DIRECT (bitvector_of_nat 8 224).
    83 
    84 axiom ImplementedInRuntime: False.
    8582
    8683definition translate_statements ≝
     
    9087  λstatement: pre_lin_statement globals_old.
    9188  match statement with
    92   [ joint_st_goto lbl ⇒ Jmp (word_of_identifier ? lbl)
    93   | joint_st_extension ext ⇒ Instruction (NOP ?) (* XXX: NOP or something else? *)
    94   | joint_st_return ⇒ Instruction (RET ?)
    95   | joint_st_sequential instr _ ⇒
     89  [ GOTO lbl ⇒ Jmp (word_of_identifier ? lbl)
     90  | RETURN ⇒ Instruction (RET ?)
     91  | sequential instr _ ⇒
    9692      match instr with
    97       [ joint_instr_comment comment ⇒ Comment comment
    98       | joint_instr_cost_label lbl ⇒ Cost (Identifier_of_costlabel lbl)
    99       | joint_instr_pop ⇒ Instruction (POP ? accumulator_address)
    100       | joint_instr_push ⇒ Instruction (PUSH ? accumulator_address)
    101       | joint_instr_clear_carry ⇒ Instruction (CLR ? CARRY)
    102       | joint_instr_call_id f ⇒ Call (word_of_identifier ? f)
    103       | joint_instr_opaccs accs ⇒
     93      [ extension ext ⇒ ⊥
     94      | COMMENT comment ⇒ Comment comment
     95      | COST_LABEL lbl ⇒ Cost (word_of_identifier ? lbl)
     96      | POP _ ⇒ Instruction (POP ? accumulator_address)
     97      | PUSH _ ⇒ Instruction (PUSH ? accumulator_address)
     98      | CLEAR_CARRY ⇒ Instruction (CLR ? CARRY)
     99      | CALL_ID f _ _ ⇒ Call (word_of_identifier ? f)
     100      | OPACCS accs _ _ _ _ ⇒
    104101        match accs with
    105102        [ Mul ⇒ Instruction (MUL ? ACC_A ACC_B)
    106103        | DivuModu ⇒ Instruction (DIV ? ACC_A ACC_B)
    107104        ]
    108       | joint_instr_op1 op1
     105      | OP1 op1 _ _
    109106        match op1 with
    110107        [ Cmpl ⇒ Instruction (CPL ? ACC_A)
    111108        | Inc ⇒ Instruction (INC ? ACC_A)
    112109        ]
    113       | joint_instr_op2 op2 reg ⇒
     110      | OP2 op2 _ _ reg ⇒
    114111        match op2 with
    115112        [ Add ⇒
     
    192189          ] (subaddressing_modein … reg')
    193190        ]
    194       | joint_instr_int reg byte ⇒
     191      | INT reg byte ⇒
    195192        let reg' ≝ register_address reg in
    196193          match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
     
    205202          | _ ⇒ λother: False. ⊥
    206203          ] (subaddressing_modein … reg')
    207       | joint_instr_from_acc reg ⇒
    208         let reg' ≝ register_address reg in
    209           match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
    210                                                          direct;
    211                                                          registr ]] x) → ? with
    212           [ REGISTER r ⇒ λregister8: True.
    213             Instruction (MOV ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? (inr ? ? 〈REGISTER r, ACC_A〉))))))
    214           | ACC_A ⇒ λacc: True.
    215             Instruction (NOP ?)
    216           | DIRECT d ⇒ λdirect8: True.
    217             Instruction (MOV ? (inl ? ? (inl ? ? (inl ? ? (inr ? ? 〈DIRECT d, ACC_A〉)))))
    218           | _ ⇒ λother: False. ⊥
    219           ] (subaddressing_modein … reg')
    220       | joint_instr_to_acc reg ⇒
    221         let reg' ≝ register_address reg in
    222           match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
    223                                                          direct;
    224                                                          registr ]] x) → ? with
    225           [ REGISTER r ⇒ λregister9: True.
    226             Instruction (MOV ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? 〈ACC_A, REGISTER r〉))))))
    227           | DIRECT d ⇒ λdirect9: True.
    228             Instruction (MOV ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? 〈ACC_A, DIRECT d〉))))))
    229           | ACC_A ⇒ λacc_a: True.
    230             Instruction (NOP ?)
    231           | _ ⇒ λother: False. ⊥
    232           ] (subaddressing_modein … reg')
    233       | joint_instr_load ⇒ Instruction (MOVX ? (inl ? ? 〈ACC_A, EXT_INDIRECT_DPTR〉))
    234       | joint_instr_store ⇒ Instruction (MOVX ? (inr ? ? 〈EXT_INDIRECT_DPTR, ACC_A〉))
    235       | joint_instr_address addr proof ⇒
     204      | MOVE regs ⇒
     205         match regs with
     206          [ from_acc reg ⇒
     207             let reg' ≝ register_address reg in
     208               match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
     209                                                              direct;
     210                                                              registr ]] x) → ? with
     211               [ REGISTER r ⇒ λregister8: True.
     212                 Instruction (MOV ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? (inr ? ? 〈REGISTER r, ACC_A〉))))))
     213               | ACC_A ⇒ λacc: True.
     214                 Instruction (NOP ?)
     215               | DIRECT d ⇒ λdirect8: True.
     216                 Instruction (MOV ? (inl ? ? (inl ? ? (inl ? ? (inr ? ? 〈DIRECT d, ACC_A〉)))))
     217               | _ ⇒ λother: False. ⊥
     218               ] (subaddressing_modein … reg')
     219          | to_acc reg ⇒
     220             let reg' ≝ register_address reg in
     221               match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
     222                                                              direct;
     223                                                              registr ]] x) → ? with
     224               [ REGISTER r ⇒ λregister9: True.
     225                 Instruction (MOV ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? 〈ACC_A, REGISTER r〉))))))
     226               | DIRECT d ⇒ λdirect9: True.
     227                 Instruction (MOV ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? 〈ACC_A, DIRECT d〉))))))
     228               | ACC_A ⇒ λacc_a: True.
     229                 Instruction (NOP ?)
     230               | _ ⇒ λother: False. ⊥
     231               ] (subaddressing_modein … reg')]
     232      | LOAD _ _ _ ⇒ Instruction (MOVX ? (inl ? ? 〈ACC_A, EXT_INDIRECT_DPTR〉))
     233      | STORE _ _ _ ⇒ Instruction (MOVX ? (inr ? ? 〈EXT_INDIRECT_DPTR, ACC_A〉))
     234      | ADDRESS addr proof _ _ ⇒
    236235        let look ≝ association addr globals (prf ? proof) in
    237236          Instruction (MOV ? (inl ? ? (inl ? ? (inr ? ? (〈DPTR, (data16_of_int look)〉)))))
    238       | joint_instr_cond_acc lbl ⇒
     237      | COND _ lbl ⇒
    239238        (* dpm: this should be handled in translate_code! *)
    240239        Instruction (JNZ ? (word_of_identifier ? lbl))
    241       | joint_instr_set_carry
     240      | SET_CARRY
    242241        Instruction (SETB ? CARRY)
    243242      ]
     
    245244  try assumption
    246245  try @ I
    247   cases ImplementedInRuntime
    248 qed.
     246qed.
     247
     248(*CSC: XXXXXXXXXXX looks bad: what invariant is needed here? *)
     249definition ident_of_label: label → ident ≝
     250 λl. an_identifier … (word_of_identifier … l).
    249251
    250252definition build_translated_statement ≝
     
    253255  λprf.
    254256  λstatement: lin_statement globals_old.
    255     〈\fst statement, translate_statements globals globals_old prf (\snd statement)〉.
     257    〈option_map … ident_of_label (\fst statement), translate_statements globals globals_old prf (\snd statement)〉.
    256258
    257259definition translate_code ≝
     
    270272    //
    271273  | #G2 #G02 #IH (* CSC: understand here *)
    272     whd in ⊢ (% → %)
    273     normalize in ⊢ (% → %)
    274     //
    275   ]
     274    whd in ⊢ (% → %) whd in match build_translated_statement normalize nodelta
     275    cases (\fst G2) normalize // ]
    276276qed.
    277277
    278278definition translate_fun_def ≝
    279   λglobals.
     279  λglobals: list (ident × nat).
    280280  λglobals_old.
    281281  λprf.
     
    283283    let 〈id, def〉 ≝ id_def in
    284284    match def with
    285     [ lin_fu_internal code proof ⇒
    286       match translate_code globals globals_old prf code return λtranscode. well_formed_P ? ? transcode → list labelled_instruction with
     285    [ Internal int ⇒
     286      let code_proof ≝ joint_if_code … (lin_params globals_old) int in
     287      match translate_code globals globals_old prf (pi1 ?? code_proof) return λtranscode. well_formed_P ? ? transcode → list labelled_instruction with
    287288      [ nil ⇒ λprf2. ⊥
    288289      | cons hd tl ⇒ λ_.
     
    294295            | None ⇒ 〈None ?, \snd r〉
    295296            ]) rest
    296       ] (translate_code_preserves_WellFormedP globals globals_old prf code proof)
    297     | _ ⇒ [ ]
     297      ] (translate_code_preserves_WellFormedP globals globals_old prf (pi1 ?? code_proof) (pi2 ?? code_proof))
     298    | External _ ⇒ [ ]
    298299    ].
    299     @ prf2
     300@prf2
    300301qed.
    301302   
     
    307308  λmain.
    308309  λfuncts.
    309   let preamble ≝
    310     match main with
    311     [ None ⇒ [ ]
    312     | Some main' ⇒ [ 〈None ?, Call main'〉 ; 〈Some ? exit_label, Jmp exit_label〉 ]
    313     ] in
    314       preamble @ (flatten ? (map ? ? (translate_fun_def globals globals_old prf) functs)).
    315 
    316 definition globals_addr_internal ≝
    317   λres_offset.
    318   λx_size: ident × nat.
     310  let preamble ≝ [ 〈None ?, Call main〉 ; 〈Some ? exit_label, Jmp exit_label〉 ] in
     311   preamble @
     312    (flatten ? (map ? ? (translate_fun_def globals globals_old prf) functs)).
     313
     314(*CSC: region silently thrown away here *)
     315definition globals_addr ≝
     316 λl.
     317  let globals_addr_internal ≝
     318   λres_offset.
     319   λx_size: ident × region × nat.
    319320    let 〈res, offset〉 ≝ res_offset in
    320     let 〈x, size〉 ≝ x_size in
    321       〈〈x, offset〉 :: res, offset + size〉.
    322 
    323 definition globals_addr ≝
    324   λl.
     321    let 〈x, region, size〉 ≝ x_size in
     322      〈〈x, offset〉 :: res, offset + size〉
     323  in
    325324    \fst (foldl ? ? globals_addr_internal 〈[ ], 0〉 l).
    326      
     325
    327326(* dpm: plays the role of the string "_exit" in the O'caml source *)
    328 axiom identifier_prefix: Identifier.
     327axiom identifier_prefix: Word.
     328(*CSC: XXXXXXX wrong anyway since labels from different functions can now
     329  clash with each other and with names of functions *)
     330axiom fresh_prefix: BitVectorTrieSet 16 → Word → Word.
    329331
    330332(* dpm: fresh prefix stuff needs unifying with brian *)
    331 
    332 (*
    333 definition translate ≝
     333definition translate : lin_program → pseudo_assembly_program ≝
    334334  λp.
    335   let prog_lbls ≝ program_labels p in
     335  let prog_lbls ≝ program_labels p in
    336336  let exit_label ≝ fresh_prefix prog_lbls identifier_prefix in
    337   let global_addr ≝ globals_addr (LIN_Pr_vars p) in
    338     〈global_addr, translate_functs global_addr (map ? ? (fst ? ?) (LIN_Pr_vars p)) ? exit_label (LIN_Pr_main p) (LIN_Pr_funs p)〉.
    339 *)
     337  let global_addr ≝ globals_addr (prog_vars … p) in
     338  let global_addr' ≝ map ?? (λx_off. let 〈x,off〉 ≝ x_off in 〈word_of_identifier ? x,off〉) global_addr in
     339    〈global_addr', translate_functs global_addr (prog_var_names … p) ? exit_label (word_of_identifier … (prog_main … p)) (prog_funct … p)〉.
     340 #i normalize nodelta -global_addr' global_addr exit_label prog_lbls;
     341 normalize in match prog_var_names normalize nodelta
     342 elim (prog_vars … p) //
     343 #hd #tl #IH whd in ⊢ (% → %)
     344 whd in match globals_addr normalize nodelta
     345 whd in match (foldl ???? (hd::tl)) normalize nodelta
     346 cases hd * #id #reg #size normalize nodelta
     347 cases daemon (*CSC: provable using a pair of lemmas over foldl *)
     348qed.
  • Deliverables/D3.3/id-lookup-branch/LTL/LTL.ma

    r1197 r1311  
    1 include "common/Graphs.ma".
    2 include "utilities/IdentifierTools.ma".
    31include "joint/Joint.ma".
    42
    5 definition ltl_params: params ≝
    6  mk_params
    7    unit unit unit unit registers_move Register
    8      unit unit unit unit.
     3definition ltl_params__: params__ ≝
     4 (mk_params__ unit unit unit unit registers_move Register nat unit False).
     5definition ltl_params_ : params_ ≝ graph_params_ ltl_params__.
     6definition ltl_params0 : params0 ≝ mk_params0 ltl_params__ unit unit.
     7definition ltl_params1 : params1 ≝ mk_params1 ltl_params0 unit.
     8definition ltl_params: ∀globals. params globals ≝ graph_params ltl_params1.
    99
    10 definition ltl_statement ≝ λglobals: list ident. joint_statement ltl_params globals.
    11  
    12 definition ltl_statement_graph ≝ λglobals. graph (ltl_statement globals).
    13  
    14 record ltl_internal_function (globals: list ident): Type[0] ≝
    15 {
    16   ltl_if_luniverse: universe LabelTag;
    17   ltl_if_runiverse: universe RegisterTag;
    18   ltl_if_stacksize: nat;
    19   ltl_if_graph: ltl_statement_graph globals;
    20   ltl_if_entry: Σl: label. lookup ? ? ltl_if_graph l ≠ None ?;
    21   ltl_if_exit: Σl: label. lookup ? ? ltl_if_graph l ≠ None ?
    22 }.
     10definition ltl_statement ≝ joint_statement ltl_params_.
    2311
    24 inductive ltl_function_definition (globals: list ident): Type[0] ≝
    25   | ltl_fu_internal_function: ltl_internal_function globals → ltl_function_definition globals
    26   | ltl_fu_external_function: external_function → ltl_function_definition globals.
    27  
    28 record ltl_program (globals: list (ident × nat)): Type[0] ≝
    29 {
    30   ltl_pr_funcs: list (ident × (ltl_function_definition (map ? ? \fst globals)));
    31   ltl_pr_main: option ident
    32 }.
     12definition ltl_program ≝ joint_program ltl_params.
     13
     14definition ltl_internal_function ≝
     15 λglobals. joint_internal_function … (ltl_params globals).
  • Deliverables/D3.3/id-lookup-branch/LTL/LTLToLIN.ma

    r1197 r1311  
    22include "LIN/LIN.ma".
    33include "utilities/BitVectorTrieSet.ma".
    4 include "common/Graphs.ma".
    5 
    6 axiom LTLTag: String.
     4include alias "common/Graphs.ma".
    75
    86definition translate_statement: ∀globals. ltl_statement globals → pre_lin_statement globals ≝
     
    108  λs: ltl_statement globals.
    119  match s with
    12   [ joint_st_return ⇒ joint_st_return lin_params globals
    13   | joint_st_sequential instr lbl ⇒ joint_st_sequential lin_params globals instr lbl
    14   | joint_st_goto l ⇒ joint_st_goto lin_params globals l
    15   | joint_st_extension ext ⇒ joint_st_extension lin_params globals ext
     10  [ RETURN ⇒ RETURN ??
     11  | sequential instr lbl ⇒ sequential … instr it
     12  | GOTO l ⇒ GOTO lin_params_ globals l
    1613  ].
    17    
    18 definition require: label → BitVectorTrieSet 16 → BitVectorTrieSet 16 ≝
    19   λl: label.
    20   λg: BitVectorTrieSet 16.
    21     set_insert ? (word_of_identifier ? l) g.
    22    
    23 definition mark: label → BitVectorTrieSet 16 → BitVectorTrieSet 16 ≝
    24   λl: label.
    25   λg: BitVectorTrieSet 16.
    26     set_insert ? (word_of_identifier ? l) g.
    27    
    28 definition marked: label → BitVectorTrieSet 16 → bool ≝
    29   λl: label.
    30   λg: BitVectorTrieSet 16.
    31     set_member ? (word_of_identifier ? l) g.
    32    
    33 (* alias id "lookupn" = "cic:/matita/cerco/common/Identifiers/lookup.def(3)". *)
    34    
    35 definition graph_lookup ≝
    36   λglobals: list ident.
    37   λl: label.
    38   λgr: ltl_statement_graph globals.
    39     lookup LabelTag ? gr (an_identifier LabelTag (word_of_identifier ? l)).
    40    
    41 definition fetch: ∀globals: list ident. label → ltl_statement_graph globals → option (ltl_statement globals) ≝
    42   λglobals: list ident.
    43   λl: label.
    44   λg: ltl_statement_graph globals.
    45     graph_lookup globals l g.
    4614
    47 definition foo ≝
    48   λl2, visited, required, globals, generated, g, n.
    49   λvisit:
    50   ∀globals: list ident.
    51   ∀g: ltl_statement_graph globals.
    52   ∀required: BitVectorTrieSet 16.
    53   ∀visited: BitVectorTrieSet 16.
    54   ∀generated: list (pre_lin_statement globals).
    55   ∀l: label.
    56   ∀n: nat.
    57     BitVectorTrieSet 16 × (list (pre_lin_statement globals)).
    58   if marked l2 visited then
    59     〈require l2 required, (joint_st_goto … globals l2) :: generated〉
    60   else
    61    visit globals g required visited generated l2 n.
     15(* Invariant: l has not been visited yet the very first time the
     16   function is called and in the true branch of a conditional call.
     17   This avoid useless gotos.
     18   
     19   Note: the OCaml code contains some useful explanatory comments. *)
     20let rec visit
     21  (globals: list ident) (g: label → option (ltl_statement globals))
     22  (required: BitVectorTrieSet 16) (visited: BitVectorTrieSet 16)
     23  (generated: list (lin_statement globals)) (l: label) (n: nat)
     24    on n: BitVectorTrieSet 16 × (list (lin_statement globals)) ≝
     25  match n with
     26  [ O ⇒ ⊥ (* CSC: Case to be made impossible; use dummy value? *)
     27  | S n' ⇒
     28    if set_member … (word_of_identifier … l) visited then
     29     〈set_insert ? (word_of_identifier ? l) required, 〈None …, GOTO … globals l〉 :: generated〉
     30    else
     31     let visited' ≝ set_insert ? (word_of_identifier ? l) visited in
     32     match g (an_identifier LabelTag (word_of_identifier … l)) with
     33     [ None ⇒ ⊥ (* Case to be made impossible with more dependent types *)
     34     | Some statement ⇒
     35       let translated_statement ≝ translate_statement globals statement in
     36       let generated' ≝ 〈Some … l, translated_statement〉 :: generated in
     37       match statement with
     38       [ sequential instr l2 ⇒
     39         match instr with
     40         [ COND acc_a_reg l1 ⇒
     41            let 〈required', generated''〉 ≝
     42             visit globals g required visited' generated' l2 n' in
     43            let required'' ≝ set_insert ? (word_of_identifier ? l1) required' in
     44             if set_member … (word_of_identifier … l1) visited' then
     45               〈required', generated''〉
     46             else
     47               visit globals g required'' visited' generated'' l1 n'
     48         | _ ⇒ visit globals g required visited' generated' l2 n']
     49     | RETURN ⇒ 〈required, generated'〉
     50     | GOTO l2 ⇒ visit globals g required visited' generated' l2 n']]].
     51[1,2: @daemon (*CSC: impossible cases, use more dependent types *) ]
     52qed.
    6253
    63 (* XXX: look at this.  way too complicated to understand whether it is correct,
    64    in my opinion.
    65 *)
    66 let rec visit
    67   (globals: list ident) (g: ltl_statement_graph globals)
    68   (required: BitVectorTrieSet 16) (visited: BitVectorTrieSet 16)
    69   (generated: list (pre_lin_statement globals)) (l: label) (n: nat)
    70     on n: BitVectorTrieSet 16 × (list (pre_lin_statement globals)) ≝
    71   match n with
    72   [ O ⇒ 〈required, generated〉
    73   | S n' ⇒
    74     let visited' ≝ mark l visited in
    75     match fetch globals l g with
    76     [ None ⇒ 〈required, generated〉 (* dpm: correct? *)
    77     | Some statement ⇒
    78       let translated_statement ≝ translate_statement globals statement in
    79       let generated'' ≝ translated_statement :: generated in
    80       match statement with
    81       [ joint_st_sequential instr l2 ⇒
    82         match instr with
    83         [ joint_instr_cond acc_a_reg l1 ⇒
    84               let required' ≝
    85                 if marked l2 visited' then
    86                   require l2 required
    87                 else
    88                   required in
    89               let 〈required', generated''〉 ≝
    90                foo l2 visited' required' globals generated'' g n' visit (*
    91                 if marked l2 visited' then
    92                   〈required', (Joint_St_Goto ? globals l2) :: generated''〉
    93                 else
    94                   visit globals g required' visited' generated'' l2 n'*) in
    95               let required'' ≝ require l1 required' in
    96                 if ¬(marked l1 visited') then
    97                   visit globals g required'' visited' generated'' l1 n'
    98                 else
    99                   〈required', generated''〉
    100           | _ ⇒
    101             let required' ≝
    102               if marked l2 visited' then
    103                 require l2 required
    104               else
    105                 required in
    106             if marked l2 visited' then
    107               〈required', joint_st_goto … globals l2 :: generated''〉
    108             else
    109               visit globals g required' visited' generated'' l2 n'
    110           ]
    111     | joint_st_return ⇒ 〈required, generated''〉 (* dpm: correct? *)
    112     | joint_st_goto l ⇒
    113       let required' ≝
    114         if marked l visited' then
    115          require l required
    116         else
    117          required
    118       in
    119         if marked l visited' then
    120           〈required', joint_st_goto … globals l :: generated''〉
    121         else
    122           visit globals g required' visited' generated'' l n'
    123     | joint_st_extension ext ⇒ 〈required, generated〉
    124     ]
    125   ]
    126 ].
     54(* CSC: The branch compression (aka tunneling) optimization is not implemented
     55   in Matita *)
     56definition branch_compress ≝ λglobals.λa:label → option (ltl_statement globals).a.
    12757
    128 (*
    129 definition translate_graph ≝
    130   λglobals: list Identifier.
    131   λg: LTLStatementGraph globals.
    132   λentry: Identifier.
    133     let visited ≝ set_empty ? in
    134     let required ≝ set_insert ? entry (set_empty ?) in
    135     let 〈required', translated〉 ≝ visit globals g required visited [ ] entry in
    136     let reversed ≝ rev ? translated in
    137       filter (λs: PreLINStatement globals. ?) reversed.
    138 *)
     58definition translate_graph:
     59 ∀globals. label → nat →
     60  (label → option (ltl_statement globals)) → codeT … (lin_params globals)
     61
     62 λglobals,entry,labels_upper_bound,g.
     63  let g ≝ branch_compress ? g in
     64  let visited ≝ set_empty ? in
     65  let required ≝ set_insert ? (word_of_identifier … entry) (set_empty ?) in
     66  let 〈required', translated〉 ≝ visit globals g required visited [ ] entry labels_upper_bound in
     67  let reversed ≝ rev ? translated in
     68  let final ≝
     69   map ??
     70    (λs. let 〈l,x〉 ≝ s in
     71      match l with
     72       [ None ⇒ 〈None …,x〉
     73       | Some l ⇒
     74          〈if set_member … (word_of_identifier … l) required' then Some ? l else None ?,
     75           x〉])
     76    reversed
     77  in
     78   dp … final ?.
     79(*CSC: XXXXXXX missing proof of well formedness here; but it seems false! *)
     80cases daemon
     81qed.
     82
     83definition translate_int_fun:
     84 ∀globals.
     85  joint_internal_function … (ltl_params globals) →
     86   joint_internal_function … (lin_params globals)
     87
     88 λglobals,f.
     89  mk_joint_internal_function globals (lin_params globals)
     90   (joint_if_luniverse ?? f) (joint_if_runiverse ?? f) it it it (joint_if_stacksize ?? f)
     91    (translate_graph globals (joint_if_entry ?? f) (nat_of_bitvector … (next_identifier … (joint_if_luniverse … f)))
     92     (lookup ?? (joint_if_code … f)))
     93    ??.
     94cases daemon (*CSC: XXXXXXXXX Dead code produced *)
     95qed.
     96
     97definition ltl_to_lin : ltl_program → lin_program ≝
     98 λp. transform_program … p (transf_fundef … (translate_int_fun …)).
  • Deliverables/D3.3/id-lookup-branch/RTL/RTL.ma

    r1153 r1311  
    1 include "basics/list.ma".
    2 include "common/Registers.ma".
    3 include "common/AST.ma".
    4 include "common/Graphs.ma".
    5 include "common/CostLabel.ma".
     1include "joint/Joint.ma".
    62
    7 definition registers ≝ list register.
     3(*CSC: XXX PROBLEM HERE. Tailcalls are not instructions, but statements since they
     4  are not sequential. Thus there is a dummy label at the moment in the code.
     5  To be fixed once we understand exactly what to do with tail calls. *)
     6inductive rtl_statement_extension: Type[0] ≝
     7  | rtl_st_ext_address: register → register → rtl_statement_extension
     8  | rtl_st_ext_call_ptr: register → register → list register → list register → rtl_statement_extension
     9  | rtl_st_ext_tailcall_id: ident → list register → rtl_statement_extension
     10  | rtl_st_ext_tailcall_ptr: register → register → list register → rtl_statement_extension.
    811
    9 inductive rtl_statement: Type[0] ≝
    10   | rtl_st_skip: label → rtl_statement
    11   | rtl_st_cost: costlabel → label → rtl_statement
    12                 (* ldest, hdest, symbol, next *)
    13   | rtl_st_addr: register → register → ident → label → rtl_statement
    14                 (* ldest, hdest, next *)
    15   | rtl_st_stack_addr: register → register → label → rtl_statement
    16   | rtl_st_int: register → Byte → label → rtl_statement
    17                 (* dest, src, next *)
    18   | rtl_st_move: register → register → label → rtl_statement
    19   | rtl_st_clear_carry: label → rtl_statement
    20                 (* op, acc dest, bacc dest, acc src, bacc src, next *)
    21   | rtl_st_opaccs: OpAccs → register → register → register → register → label → rtl_statement
    22                 (* op, dest, src, next *)
    23   | rtl_st_op1: Op1 → register → register → label → rtl_statement
    24                 (* op, dest, src1, src2, next *)
    25   | rtl_st_op2: Op2 → register → register → register → label → rtl_statement
    26   | rtl_st_load: register → register → register → label → rtl_statement
    27   | rtl_st_store: register → register → register → label → rtl_statement
    28   | rtl_st_call_id: ident → registers → registers → label → rtl_statement
    29   | rtl_st_call_ptr: register → register → registers → registers → label → rtl_statement
    30   | rtl_st_tailcall_id: ident → registers → rtl_statement
    31   | rtl_st_tailcall_ptr: register → register → registers → rtl_statement
    32   | rtl_st_cond: register → label → label → rtl_statement
    33   | rtl_st_set_carry: label → rtl_statement
    34   | rtl_st_return: rtl_statement.
    35  
    36 definition rtl_statement_graph ≝ graph rtl_statement.
     12definition rtl_params__: params__ ≝
     13 mk_params__ register register register register (register × register) register
     14  (list register) (list register) rtl_statement_extension.
     15definition rtl_params_: params_ ≝ graph_params_ rtl_params__.
     16definition rtl_params0: params0 ≝ mk_params0 rtl_params__ (list register) (list register).
     17definition rtl_params1: params1 ≝ rtl_ertl_params1 rtl_params0.
     18definition rtl_params: ∀globals. params globals ≝ rtl_ertl_params rtl_params0.
    3719
    38 record rtl_internal_function: Type[0] ≝
    39 {
    40   rtl_if_luniverse: universe LabelTag;
    41   rtl_if_runiverse: universe RegisterTag;
    42 (*  rtl_if_sig: signature;  -- dropped in front end *)
    43   rtl_if_result   : registers;
    44   rtl_if_params   : registers;
    45   rtl_if_locals   : registers;
    46   rtl_if_stacksize: nat;
    47   rtl_if_graph    : rtl_statement_graph;
    48   rtl_if_entry    : Σl: label. lookup ? ? rtl_if_graph l ≠ None ?;
    49   rtl_if_exit     : Σl: label. lookup ? ? rtl_if_graph l ≠ None ?
    50 }.
     20definition rtl_statement ≝ joint_statement rtl_params_.
    5121
    52 definition rtl_function_definition ≝ fundef rtl_internal_function.
    53  
    54 record rtl_program: Type[0] ≝
    55 {
    56   rtl_pr_vars: list (ident × nat);
    57   rtl_pr_functs: list (ident × rtl_function_definition);
    58   rtl_pr_main: option ident
    59 }.
     22definition rtl_internal_function ≝
     23  λglobals. joint_internal_function … (rtl_params globals).
     24
     25definition rtl_program ≝ joint_program rtl_params.
     26
     27(************ Same without tail calls ****************)
     28
     29(*CSC: XXX PROBLEM HERE. Tailcalls are not instructions, but statements since they
     30  are not sequential. Thus there is a dummy label at the moment in the code.
     31  To be fixed once we understand exactly what to do with tail calls. *)
     32inductive rtlntc_statement_extension: Type[0] ≝
     33  | rtlntc_st_ext_address: register → register → rtlntc_statement_extension
     34  | rtlntc_st_ext_call_ptr: register → register → list register → list register → rtlntc_statement_extension.
     35
     36definition rtlntc_params__: params__ ≝
     37 mk_params__ register register register register (register × register) register
     38  (list register) (list register) rtlntc_statement_extension.
     39definition rtlntc_params_: params_ ≝ graph_params_ rtlntc_params__.
     40definition rtlntc_params0: params0 ≝ mk_params0 rtlntc_params__ (list register) (list register).
     41definition rtlntc_params1: params1 ≝ rtl_ertl_params1 rtlntc_params0.
     42definition rtlntc_params: ∀globals. params globals ≝ rtl_ertl_params rtlntc_params0.
     43
     44definition rtlntc_statement ≝ joint_statement rtlntc_params_.
     45
     46definition rtlntc_internal_function ≝
     47  λglobals. joint_internal_function … (rtlntc_params globals).
     48
     49definition rtlntc_program ≝ joint_program rtlntc_params.
  • Deliverables/D3.3/id-lookup-branch/RTL/RTLTailcall.ma

    r1081 r1311  
    22
    33definition simplify_stmt ≝
     4  λglobals.
    45  λexit: label.
    56  λlbl: label.
    6   λstmt.
    7   λgraph: rtl_statement_graph.
     7  λstmt: rtl_statement globals.
     8  λgraph: codeT … (rtlntc_params globals).
    89  match stmt with
    9   [ rtl_st_tailcall_id f args ⇒
    10       add ? ? graph lbl (rtl_st_call_id f args [ ] exit)
    11   | rtl_st_tailcall_ptr f1 f2 args ⇒
    12       add ? ? graph lbl (rtl_st_call_ptr f1 f2 args [ ] exit)
    13   | _ ⇒ graph
    14   ].
     10  [ sequential seq DUMMY ⇒
     11     match seq with
     12      [ extension ext ⇒
     13         match ext with
     14          [ rtl_st_ext_tailcall_id f args ⇒
     15              add ? ? graph lbl (sequential … (CALL_ID … f args [ ]) exit)
     16          | rtl_st_ext_tailcall_ptr f1 f2 args ⇒
     17              add ? ? graph lbl (sequential … (extension … (rtlntc_st_ext_call_ptr f1 f2 args [ ])) exit)
     18          | _ ⇒ graph ]
     19      | _ ⇒ graph ]
     20  | _ ⇒ graph ].
    1521
    1622definition simplify_graph ≝
     23  λglobals.
    1724  λexit: label.
    18   λgraph: rtl_statement_graph.
    19     foldi ? ? ? (simplify_stmt exit) graph graph.
     25  λgraph: codeT … (rtl_params globals).
     26    foldi ? ? ? (simplify_stmt globals exit) graph (empty_map …).
    2027
    2128axiom simplify_graph_preserves_labels:
    22   ∀g: rtl_statement_graph.
     29  ∀globals.
     30  ∀g: codeT … (rtl_params globals).
    2331  ∀l: label.
    2432  ∀exit: label.
    25     lookup ? ? g l ≠ None ? → lookup ? ? (simplify_graph exit g) l ≠ None ?.
     33    lookup ? ? g l ≠ None ? → lookup ? ? (simplify_graph globals exit g) l ≠ None ?.
    2634   
    27 definition simplify_internal ≝
    28   λdef.
    29     let rtl_if_luniverse' ≝ rtl_if_luniverse def in
    30     let rtl_if_runiverse' ≝ rtl_if_runiverse def in
    31     let rtl_if_result' ≝ rtl_if_result def in
    32     let rtl_if_params' ≝ rtl_if_params def in
    33     let rtl_if_locals' ≝ rtl_if_locals def in
    34     let rtl_if_stacksize' ≝ rtl_if_stacksize def in
    35     let rtl_if_graph' ≝ simplify_graph (rtl_if_exit def) (rtl_if_graph def) in
    36     let rtl_if_entry' ≝ rtl_if_entry def in
    37     let rtl_if_exit' ≝ rtl_if_exit def in
    38       mk_rtl_internal_function
    39         rtl_if_luniverse' rtl_if_runiverse'
    40         rtl_if_result' rtl_if_params' rtl_if_locals' rtl_if_stacksize'
    41         rtl_if_graph' ? ?.
    42   normalize nodelta
    43   [1: cases rtl_if_entry'
    44       #ENTRY #ENTRY_PRF
    45       %
    46       [1: @ENTRY
    47       |2: @simplify_graph_preserves_labels
    48           @ENTRY_PRF
    49       ]
    50   |2: cases rtl_if_exit'
    51       #EXIT #EXIT_PRF
    52       %
    53       [1: @EXIT
    54       |2: @simplify_graph_preserves_labels
    55           @EXIT_PRF
    56       ]
    57   ]
     35definition simplify_internal :
     36 ∀globals.
     37  joint_internal_function … (rtl_params globals) →
     38   joint_internal_function … (rtlntc_params globals)
     39
     40  λglobals,def.
     41    let graph ≝ simplify_graph … (joint_if_exit … def) (joint_if_code … def) in
     42      mk_joint_internal_function …
     43       (joint_if_luniverse … def) (joint_if_runiverse … def)
     44       (joint_if_result … def) (joint_if_params … def) (joint_if_locals … def)
     45       (joint_if_stacksize … def) graph
     46       (pi1 … (joint_if_entry … def)) (pi1 … (joint_if_exit … def)).
     47 [ cases (joint_if_entry … def) | cases (joint_if_exit … def) ]
     48 #l #IH @simplify_graph_preserves_labels @IH
    5849qed.
    5950
    60 definition simplify_funct ≝
    61   λid_def: ident × ?.
    62   let 〈id, def〉 ≝ id_def in
    63   let def' ≝
    64     match def with
    65     [ Internal def ⇒ Internal ? (simplify_internal def)
    66     | External def ⇒ External ? def
    67     ]
    68   in
    69     〈id, def'〉.
    70  
    71 definition tailcall_simplify ≝
    72   λp.
    73   let rtl_pr_vars' ≝ rtl_pr_vars p in
    74   let rtl_pr_functs' ≝ map ? ? simplify_funct (rtl_pr_functs p) in
    75   let rtl_pr_main' ≝ rtl_pr_main p in
    76     mk_rtl_program rtl_pr_vars' rtl_pr_functs' rtl_pr_main'.
     51definition tailcall_simplify : rtl_program → rtlntc_program ≝
     52 λp. transform_program … p (transf_fundef … (simplify_internal …)).
  • Deliverables/D3.3/id-lookup-branch/RTL/RTLtoERTL.ma

    r1153 r1311  
    1 include "RTL/RTL.ma".
    21include "RTL/RTLTailcall.ma".
    32include "utilities/RegisterSet.ma".
    43include "common/Identifiers.ma".
    54include "ERTL/ERTL.ma".
    6 
    7 definition change_exit_label ≝
    8   λl: label.
    9   λp: ertl_internal_function.
    10   λprf: lookup ? ? (ertl_if_graph p) l ≠ None ?.
    11   let ertl_if_luniverse' ≝ ertl_if_luniverse p in
    12   let ertl_if_runiverse' ≝ ertl_if_runiverse p in
    13   let ertl_if_params' ≝ ertl_if_params p in
    14   let ertl_if_locals' ≝ ertl_if_locals p in
    15   let ertl_if_stacksize' ≝ ertl_if_stacksize p in
    16   let ertl_if_graph' ≝ ertl_if_graph p in
    17   let ertl_if_entry' ≝ ertl_if_entry p in
    18   let ertl_if_exit' ≝ l in
    19     mk_ertl_internal_function ertl_if_luniverse' ertl_if_runiverse'
    20                               ertl_if_params' ertl_if_locals' ertl_if_stacksize'
    21                               ertl_if_graph' ertl_if_entry' ertl_if_exit'.
    22   @prf
    23 qed.
    24 
    25 definition change_entry_label ≝
    26   λl: label.
    27   λp: ertl_internal_function.
    28   λprf: lookup ? ? (ertl_if_graph p) l ≠ None ?.
    29   let ertl_if_luniverse' ≝ ertl_if_luniverse p in
    30   let ertl_if_runiverse' ≝ ertl_if_runiverse p in
    31   let ertl_if_params' ≝ ertl_if_params p in
    32   let ertl_if_locals' ≝ ertl_if_locals p in
    33   let ertl_if_stacksize' ≝ ertl_if_stacksize p in
    34   let ertl_if_graph' ≝ ertl_if_graph p in
    35   let ertl_if_entry' ≝ l in
    36   let ertl_if_exit' ≝ ertl_if_exit p in
    37     mk_ertl_internal_function ertl_if_luniverse' ertl_if_runiverse'
    38                               ertl_if_params' ertl_if_locals' ertl_if_stacksize'
    39                               ertl_if_graph' ertl_if_entry' ertl_if_exit'.
    40   @prf
    41 qed.
    42                              
    43 definition add_graph ≝
    44   λl: label.
    45   λstmt.
    46   λp.
    47   let ertl_if_luniverse' ≝ ertl_if_luniverse p in
    48   let ertl_if_runiverse' ≝ ertl_if_runiverse p in
    49   let ertl_if_params' ≝ ertl_if_params p in
    50   let ertl_if_locals' ≝ ertl_if_locals p in
    51   let ertl_if_stacksize' ≝ ertl_if_stacksize p in
    52   let ertl_if_graph' ≝ add ? ? (ertl_if_graph p) l stmt in
    53   let ertl_if_entry' ≝ ertl_if_entry p in
    54   let ertl_if_exit' ≝ ertl_if_exit p in
    55     mk_ertl_internal_function ertl_if_luniverse' ertl_if_runiverse'
    56                               ertl_if_params' ertl_if_locals' ertl_if_stacksize'
    57                               ertl_if_graph' ? ?.
    58   normalize nodelta;
    59   [1: generalize in match ertl_if_entry';
    60       #HYP
    61       cases HYP
    62       #LBL #LBL_PRF
    63       %
    64       [1: @LBL
    65       |2: @graph_add_lookup
    66           @LBL_PRF
    67       ]
    68   |2: generalize in match ertl_if_exit';
    69       #HYP
    70       cases HYP
    71       #LBL #LBL_PRF
    72       %
    73       [1: @LBL
    74       |2: @graph_add_lookup
    75           @LBL_PRF
    76       ]
    77   ]
    78 qed.
    79                              
    80 definition fresh_label ≝
    81   λdef.
    82     fresh LabelTag (ertl_if_luniverse def).
    83    
    84 definition change_label ≝
    85   λl.
    86   λe: ertl_statement.
    87   match e with
    88   [ ertl_st_skip _ ⇒ ertl_st_skip l
    89   | ertl_st_comment s _ ⇒ ertl_st_comment s l
    90   | ertl_st_cost c _ ⇒ ertl_st_cost c l
    91   | ertl_st_get_hdw r1 r2 _ ⇒ ertl_st_get_hdw r1 r2 l
    92   | ertl_st_set_hdw r1 r2 _ ⇒ ertl_st_set_hdw r1 r2 l
    93   | ertl_st_hdw_to_hdw r1 r2 _ ⇒ ertl_st_hdw_to_hdw r1 r2 l
    94   | ertl_st_new_frame _ ⇒ ertl_st_new_frame l
    95   | ertl_st_del_frame _ ⇒ ertl_st_del_frame l
    96   | ertl_st_frame_size r _ ⇒ ertl_st_frame_size r l
    97   | ertl_st_pop r _ ⇒ ertl_st_pop r l
    98   | ertl_st_push r _ ⇒ ertl_st_push r l
    99   | ertl_st_addr r1 r2 x _ ⇒ ertl_st_addr r1 r2 x l
    100   | ertl_st_int r i _ ⇒ ertl_st_int r i l
    101   | ertl_st_move r1 r2 _ ⇒ ertl_st_move r1 r2 l
    102   | ertl_st_opaccs opaccs d1 d2 s1 s2 _ ⇒ ertl_st_opaccs opaccs d1 s1 s1 s2 l
    103   | ertl_st_op1 op1 d s1 _ ⇒ ertl_st_op1 op1 d s1 l
    104   | ertl_st_op2 op2 d s1 s2 _ ⇒ ertl_st_op2 op2 d s1 s2 l
    105   | ertl_st_clear_carry _ ⇒ ertl_st_clear_carry l
    106   | ertl_st_set_carry _ ⇒ ertl_st_set_carry l
    107   | ertl_st_load d a1 a2 _ ⇒ ertl_st_load d a1 a2 l
    108   | ertl_st_store a1 a2 s _ ⇒ ertl_st_store a1 a2 s l
    109   | ertl_st_call_id f args _ ⇒ ertl_st_call_id f args l
    110   | ertl_st_cond a i1 i2 ⇒ ertl_st_cond a i1 i2
    111   | ertl_st_return ⇒ ertl_st_return
    112   ].
    113  
    114 let rec adds_graph
    115   (stmt_list: list ertl_statement) (start_lbl: label)
    116   (dest_lbl: label) (def: ertl_internal_function)
    117     on stmt_list ≝
    118   match stmt_list with
    119   [ nil ⇒ add_graph start_lbl (ertl_st_skip dest_lbl) def
    120   | cons stmt stmt_list ⇒
    121     match stmt_list with
    122     [ nil ⇒ add_graph start_lbl (change_label dest_lbl stmt) def
    123     | _ ⇒
    124       let 〈tmp_lbl, nuniv〉 ≝ fresh_label def in
    125       let stmt ≝ change_label tmp_lbl stmt in
    126       let def ≝ add_graph start_lbl stmt def in
    127         adds_graph stmt_list tmp_lbl dest_lbl def
    128     ]
    129   ].
    130 
    131 let rec add_translates
    132   (translate_list: list ?) (start_lbl: label) (dest_lbl: label)
    133   (def: ertl_internal_function)
    134     on translate_list ≝
    135   match translate_list with
    136   [ nil ⇒ add_graph start_lbl (ertl_st_skip dest_lbl) def
    137   | cons trans translate_list ⇒
    138     match translate_list with
    139     [ nil ⇒ trans start_lbl dest_lbl def
    140     | _ ⇒
    141       let 〈tmp_lbl, nuniv〉 ≝ fresh_label def in
    142       let def ≝ trans start_lbl tmp_lbl def in
    143         add_translates translate_list tmp_lbl dest_lbl def
    144     ]
    145   ].
    146 
    147 axiom register_fresh: universe RegisterTag → register.
    148 
    149 definition fresh_reg: ertl_internal_function → ertl_internal_function × register ≝
    150   λdef.
    151     let r ≝ register_fresh (ertl_if_runiverse def) in
    152     let locals ≝ r :: ertl_if_locals def in
    153     let ertl_if_luniverse' ≝ ertl_if_luniverse def in
    154     let ertl_if_runiverse' ≝ ertl_if_runiverse def in
    155     let ertl_if_params' ≝ ertl_if_params def in
    156     let ertl_if_locals' ≝ locals in
    157     let ertl_if_stacksize' ≝ ertl_if_stacksize def in
    158     let ertl_if_graph' ≝ ertl_if_graph def in
    159     let ertl_if_entry' ≝ ertl_if_entry def in
    160     let ertl_if_exit' ≝ ertl_if_exit def in
    161       〈mk_ertl_internal_function
    162         ertl_if_luniverse' ertl_if_runiverse' ertl_if_params'
    163         ertl_if_locals' ertl_if_stacksize' ertl_if_graph'
    164         ertl_if_entry' ertl_if_exit', r〉.
    165 
    166 let rec fresh_regs
    167   (def: ertl_internal_function) (n: nat)
    168     on n ≝
    169   match n with
    170   [ O ⇒ 〈def, [ ]〉
    171   | S n' ⇒
    172     let 〈def', regs'〉 ≝ fresh_regs def n' in
    173     let 〈def', reg〉 ≝ fresh_reg def' in
    174       〈def', reg :: regs'〉
    175   ].
    176  
    177 axiom fresh_regs_length:
    178   ∀def: ertl_internal_function.
    179   ∀n: nat.
    180     |(\snd (fresh_regs def n))| = n.
    181 
    182 definition fresh_regs_strong: ? → ∀n: nat. Σregs: ertl_internal_function × (list register). |\snd regs| = n ≝
    183   λdef: ertl_internal_function.
    184   λn: nat.
    185     fresh_regs def n.
    186   @fresh_regs_length
    187 qed.
    188  
    189 definition save_hdws_internal ≝
    190   λdestr_srcr: register × Register.
    191   λstart_lbl: label.
     5include "joint/TranslateUtils.ma".
     6
     7definition save_hdws ≝
     8 λglobals,l.
     9  let save_hdws_internal ≝
     10   λdestr_srcr.λstart_lbl.
    19211    let 〈destr, srcr〉 ≝ destr_srcr in
    193       adds_graph [ ertl_st_get_hdw destr srcr start_lbl ] start_lbl.
    194  
    195 definition save_hdws ≝
    196   λl.
    197     map ? ? save_hdws_internal l.
    198    
    199 definition restore_hdws_internal ≝
    200   λdestr_srcr: Register × register.
    201   λstart_lbl: label.
    202     let 〈destr, srcr〉 ≝ destr_srcr in
    203     adds_graph [ ertl_st_set_hdw destr srcr start_lbl ] start_lbl.
    204    
    205 definition swap_components ≝
    206   λA, B: Type[0].
    207   λp: A × B.
    208   let 〈l, r〉 ≝ p in
    209   〈r, l〉.
    210    
     12     adds_graph ertl_params1 globals [ sequential ertl_params_ … (MOVE … 〈pseudo destr,hardware srcr〉) ] start_lbl
     13  in
     14   map ? ? save_hdws_internal l.
     15
    21116definition restore_hdws ≝
    212   λl.
    213     map ? ? restore_hdws_internal (map ? ? (swap_components ? ?) l).
    214 
    215 definition get_params_hdw_internal ≝
    216   λstart_lbl: label.
    217     adds_graph [ ertl_st_skip start_lbl ] start_lbl.
     17  λglobals,l.
     18   let restore_hdws_internal ≝
     19    λsrcr_destr: register × Register.
     20    λstart_lbl: label.
     21     let 〈srcr, destr〉 ≝ srcr_destr in
     22     adds_graph ertl_params1 globals [ sequential ertl_params_ … (MOVE … 〈hardware destr, pseudo srcr〉) ] start_lbl
     23   in
     24    map ? ? restore_hdws_internal l.
    21825
    21926definition get_params_hdw ≝
     27  λglobals.
    22028  λparams: list register.
    22129  match params with
    222   [ nil ⇒ [get_params_hdw_internal]
     30  [ nil ⇒ [λstart_lbl: label. adds_graph ertl_params1 globals [ GOTO … ] start_lbl]
    22331  | _ ⇒
    22432    let l ≝ zip_pottier ? ? params RegisterParams in
    225       save_hdws l
    226   ].
     33      save_hdws globals l ].
    22734
    22835definition get_param_stack ≝
     36  λglobals.
    22937  λoff: nat.
    23038  λdestr.
    23139  λstart_lbl, dest_lbl: label.
    23240  λdef.
    233   let 〈def, addr1〉 ≝ fresh_reg def in
    234   let 〈def, addr2〉 ≝ fresh_reg def in
    235   let 〈def, tmpr〉 ≝ fresh_reg def in
     41  let 〈def, addr1〉 ≝ fresh_reg def in
     42  let 〈def, addr2〉 ≝ fresh_reg def in
     43  let 〈def, tmpr〉 ≝ fresh_reg def in
    23644  let 〈carry, int_offset〉 ≝ half_add ? (bitvector_of_nat ? off) int_size in
    237   adds_graph [
    238     ertl_st_frame_size addr1 start_lbl;
    239     ertl_st_int tmpr int_offset start_lbl;
    240     ertl_st_op2 Sub addr1 addr1 tmpr start_lbl;
    241     ertl_st_get_hdw tmpr RegisterSPL start_lbl;
    242     ertl_st_op2 Add addr1 addr1 tmpr start_lbl;
    243     ertl_st_int addr2 (bitvector_of_nat 8 0) start_lbl;
    244     ertl_st_get_hdw tmpr RegisterSPH start_lbl;
    245     ertl_st_op2 Addc addr2 addr2 tmpr start_lbl;
    246     ertl_st_load destr addr1 addr2 start_lbl
     45  adds_graph ertl_params1 globals [
     46    sequential ertl_params_ … (extension … (ertl_st_ext_frame_size addr1));
     47    sequential ertl_params_ … (INT … tmpr int_offset);
     48    sequential ertl_params_ … (OP2 … Sub addr1 addr1 tmpr);
     49    sequential ertl_params_ … (MOVE … 〈pseudo tmpr, hardware RegisterSPL〉);
     50    sequential ertl_params_ … (OP2 … Add addr1 addr1 tmpr);
     51    sequential ertl_params_ … (INT … addr2 (bitvector_of_nat 8 0));
     52    sequential ertl_params_ … (MOVE … 〈pseudo tmpr, hardware RegisterSPH〉);
     53    sequential ertl_params_ … (OP2 … Addc addr2 addr2 tmpr);
     54    sequential ertl_params_ … (LOAD … destr addr1 addr2)
    24755  ] start_lbl dest_lbl def.
    24856 
    24957definition get_params_stack ≝
    250   λparams.
     58  λglobals,params.
    25159  match params with
    252   [ nil ⇒ [ λstart_lbl. adds_graph [ertl_st_skip start_lbl] start_lbl ]
    253   | _ ⇒
    254     let f ≝ λi. λr. get_param_stack i r in
    255       mapi ? ? f params
    256   ].
     60  [ nil ⇒ [ λstart_lbl. adds_graph … [GOTO …] start_lbl ]
     61  | _ ⇒ mapi ? ? (get_param_stack globals) params ].
    25762
    25863definition get_params ≝
    259   λparams.
    260   let n ≝ min (length ? params) (length ? RegisterParams) in
    261   let 〈hdw_params, stack_params〉 ≝ list_split ? n params in
    262   let hdw_params ≝ get_params_hdw hdw_params in
    263     hdw_params @ (get_params_stack stack_params).
    264  
     64  λglobals,params.
     65  let n ≝ min (length … params) (length … RegisterParams) in
     66  let 〈hdw_params, stack_params〉 ≝ list_split n params in
     67  let hdw_params ≝ get_params_hdw globals hdw_params in
     68    hdw_params @ (get_params_stack stack_params).
     69
    26570definition add_prologue ≝
     71  λglobals.
    26672  λparams: list register.
    26773  λsral.
     
    26975  λsregs.
    27076  λdef.
    271   let start_lbl ≝ ertl_if_entry def in
    272   let 〈tmp_lbl, nuniv〉 ≝ fresh_label def in
    273   match lookup ? ? (ertl_if_graph def) start_lbl
    274     return λx. lookup ? ? (ertl_if_graph def) start_lbl ≠ None ? → ertl_internal_function with
    275   [ None ⇒ λnone_absrd. ?
     77  let start_lbl ≝ joint_if_entry … (ertl_params globals) def in
     78  let 〈tmp_lbl, def〉 ≝ fresh_label … def in
     79  match lookup … (joint_if_code … def) start_lbl
     80    return λx. x ≠ None ? → ertl_internal_function globals with
     81  [ None ⇒ λnone_absrd.
    27682  | Some last_stmt ⇒ λsome_prf.
    27783    let def ≝
    278       add_translates
    279          ((adds_graph [
    280                      ertl_st_new_frame start_lbl
     84      add_translates …
     85         ((adds_graph ertl_params1 … [
     86                     sequential ertl_params_ … (extension ertl_params__ globals ertl_st_ext_new_frame)
    28187                   ]) ::
    282          (adds_graph [
    283                       ertl_st_pop sral start_lbl;
    284                       ertl_st_pop srah start_lbl
     88         (adds_graph ertl_params1 … [
     89                      sequential ertl_params_ … (POP … sral);
     90                      sequential ertl_params_ … (POP … srah)
    28591                   ]) ::
    286          (save_hdws sregs) @
    287          (get_params params))
     92         (save_hdws sregs) @
     93         (get_params params))
    28894        start_lbl tmp_lbl def
    28995    in
    290       add_graph tmp_lbl last_stmt def
     96      add_graph tmp_lbl last_stmt def
    29197  ] ?.
    292   cases not_implemented (* dep. types here *)
     98[ cases start_lbl #x #H cases daemon (* @H *) (*CSC: XXXX, no Russell *)
     99| cases (none_absrd) /2/ ]
    293100qed.
    294101
    295102definition save_return ≝
     103  λglobals.
    296104  λret_regs.
    297105  λstart_lbl: label.
    298106  λdest_lbl: label.
    299   λdef: ertl_internal_function.
    300   let 〈def, tmpr〉 ≝ fresh_reg def in
     107  λdef: ertl_internal_function globals.
     108  let 〈def, tmpr〉 ≝ fresh_reg def in
    301109  match reduce_strong ? ? RegisterSTS ret_regs with
    302110  [ dp crl crl_proof ⇒
     
    305113    let restl ≝ \snd (\fst crl) in
    306114    let restr ≝ \snd (\snd crl) in
    307     let init_tmpr ≝ ertl_st_int tmpr (zero ?) start_lbl in
    308     let f_save ≝ λst. λr. ertl_st_set_hdw st r start_lbl in
    309     let saves ≝ map2 ? ? ? f_save commonl commonr crl_proof in
    310     let f_default ≝ λst. ertl_st_set_hdw st tmpr start_lbl in
    311     let defaults ≝ map ? ? f_default restl in
    312       adds_graph (init_tmpr :: saves @ defaults) start_lbl dest_lbl def
     115    let init_tmpr ≝ sequential ertl_params_ … (INT … tmpr (zero …)) in
     116    let f_save ≝ λst. λr. sequential ertl_params_ … (MOVE … 〈hardware st, pseudo r〉) in
     117    let saves ≝ map2 f_save commonl commonr crl_proof in
     118    let f_default ≝ λst. sequential ertl_params_ … (MOVE … 〈hardware st, pseudo tmpr〉) in
     119    let defaults ≝ map f_default restl in
     120      adds_graph ertl_params1 … (init_tmpr :: saves @ defaults) start_lbl dest_lbl def
    313121  ].
    314122
    315123definition assign_result ≝
    316   λstart_lbl: label.
     124  λglobals.λstart_lbl: label.
    317125  match reduce_strong ? ? RegisterRets RegisterSTS with
    318126  [ dp crl crl_proof ⇒
    319127    let commonl ≝ \fst (\fst crl) in
    320128    let commonr ≝ \fst (\snd crl) in
    321     let f ≝ λret. λst. ertl_st_hdw_to_hdw ret st start_lbl in
     129    let f ≝ λret. λst. sequential ertl_params_ globals (MOVE … 〈hardware ret, hardware st〉) in
    322130    let insts ≝ map2 ? ? ? f commonl commonr crl_proof in
    323       adds_graph insts start_lbl
     131      adds_graph ertl_params1 … insts start_lbl
    324132  ].
    325133
    326134definition add_epilogue ≝
     135  λglobals.
    327136  λret_regs.
    328137  λsral.
     
    330139  λsregs.
    331140  λdef.
    332   let start_lbl ≝ ertl_if_exit def in
    333   let 〈tmp_lbl, nuniv〉 ≝ fresh_label def in
    334   match lookup ? ? (ertl_if_graph def) start_lbl
    335     return λx. lookup ? ? (ertl_if_graph def) start_lbl ≠ None ? → ? with
    336   [ None ⇒ λnone_absd. ?
     141  let start_lbl ≝ joint_if_exit … (ertl_params globals) def in
     142  let 〈tmp_lbl, def〉 ≝ fresh_label … def in
     143  match lookup … (joint_if_code … def) start_lbl
     144    return λx. x ≠ None ? → ertl_internal_function globals with
     145  [ None ⇒ λnone_absrd. ⊥
    337146  | Some last_stmt ⇒ λsome_prf.
    338147    let def ≝
    339       add_translates (
    340         [save_return ret_regs] @
    341         restore_hdws sregs @
    342         [adds_graph [
    343           ertl_st_push srah start_lbl;
    344           ertl_st_push sral start_lbl
     148      add_translates ertl_params1 … (
     149        [save_return globals ret_regs] @
     150        restore_hdws sregs @
     151        [adds_graph ertl_params1 … [
     152          sequential ertl_params_ … (PUSH … srah);
     153          sequential ertl_params_ … (PUSH … sral)
    345154        ]] @
    346         [adds_graph [
    347           ertl_st_del_frame start_lbl
     155        [adds_graph ertl_params1 … [
     156          sequential ertl_params_ … (extension … ertl_st_ext_del_frame)
    348157        ]] @
    349         [assign_result]
     158        [assign_result globals]
    350159      ) start_lbl tmp_lbl def
    351160    in
    352     let def ≝ add_graph tmp_lbl last_stmt def in
    353       change_exit_label tmp_lbl def ?
     161    let def' ≝ add_graph … tmp_lbl last_stmt def in
     162      set_joint_if_exit … tmp_lbl def' ?
    354163  ] ?.
    355   cases not_implemented (* dep types here, bug in matita too! *)
     164[ cases start_lbl #x #H cases daemon (* @H *) (* CSC: XXXX *)
     165| cases (none_absrd) /2/
     166| cases daemon (* CSC: XXXXX *)
     167]
    356168qed.
    357169 
    358 definition allocate_regs_internal ≝
    359   λr: Register.
    360   λdef_sregs.
    361   let 〈def, sregs〉 ≝ def_sregs in
    362   let 〈def, r'〉 ≝ fresh_reg def in
    363     〈def, 〈r', r〉 :: sregs〉.
    364  
     170
    365171definition allocate_regs ≝
     172  λglobals.
    366173  λrs.
    367174  λsaved: rs_set rs.
    368175  λdef.
     176   let allocate_regs_internal ≝
     177    λr: Register.
     178    λdef_sregs.
     179    let 〈def, sregs〉 ≝ def_sregs in
     180    let 〈def, r'〉 ≝ fresh_reg ertl_params0 globals def in
     181      〈def, 〈r', r〉 :: sregs〉
     182   in
    369183    rs_fold ? ? allocate_regs_internal saved 〈def, [ ]〉.
    370184   
    371185definition add_pro_and_epilogue ≝
     186  λglobals.
    372187  λparams.
    373188  λret_regs.
    374189  λdef.
    375   match fresh_regs_strong def 2 with
     190  match fresh_regs_strong … globals def 2 with
    376191  [ dp def_sra def_sra_proof ⇒
    377192    let def ≝ \fst def_sra in
     
    379194    let sral ≝ nth_safe ? 0 sra ? in
    380195    let srah ≝ nth_safe ? 1 sra ? in
    381     let 〈def, sregs〉 ≝ allocate_regs register_list_set RegisterCalleeSaved def in
    382     let def ≝ add_prologue params sral srah sregs def in
    383     let def ≝ add_epilogue ret_regs sral srah sregs def in
     196    let 〈def, sregs〉 ≝ allocate_regs register_list_set RegisterCalleeSaved def in
     197    let def ≝ add_prologue params sral srah sregs def in
     198    let def ≝ add_epilogue ret_regs sral srah sregs def in
    384199      def
    385200  ].
    386   [1: >def_sra_proof //
    387   |2: >def_sra_proof //
    388   ]
     201>def_sra_proof //
    389202qed.
    390203
    391204definition set_params_hdw ≝
    392   λparams.
     205  λglobals,params.
    393206  match params with
    394   [ nil ⇒ [ λstart_lbl. adds_graph [ertl_st_skip start_lbl] start_lbl]
     207  [ nil ⇒ [ λstart_lbl. adds_graph … [GOTO …] start_lbl]
    395208  | _ ⇒
    396209    let l ≝ zip_pottier ? ? params RegisterParams in
    397       restore_hdws l
     210      restore_hdws globals l
    398211  ].
    399212
    400213definition set_param_stack ≝
     214  λglobals.
    401215  λoff.
    402216  λsrcr.
    403217  λstart_lbl: label.
    404218  λdest_lbl: label.
    405   λdef: ertl_internal_function.
    406   let 〈def, addr1〉 ≝ fresh_reg def in
    407   let 〈def, addr2〉 ≝ fresh_reg def in
    408   let 〈def, tmpr〉 ≝ fresh_reg def in
     219  λdef: ertl_internal_function globals.
     220  let 〈def, addr1〉 ≝ fresh_reg def in
     221  let 〈def, addr2〉 ≝ fresh_reg def in
     222  let 〈def, tmpr〉 ≝ fresh_reg def in
    409223  let 〈ignore, int_off〉 ≝ half_add ? off int_size in
    410     adds_graph [
    411       ertl_st_int addr1 int_off start_lbl;
    412       ertl_st_get_hdw tmpr RegisterSPL start_lbl;
    413       ertl_st_clear_carry start_lbl;
    414       ertl_st_op2 Sub addr1 tmpr addr1 start_lbl;
    415       ertl_st_get_hdw tmpr RegisterSPH start_lbl;
    416       ertl_st_int addr2 (zero ?) start_lbl;
    417       ertl_st_op2 Sub addr2 tmpr addr2 start_lbl;
    418       ertl_st_store addr1 addr2 srcr start_lbl
     224    adds_graph ertl_params1 … [
     225      sequential ertl_params_ … (INT … addr1 int_off);
     226      sequential ertl_params_ … (MOVE … 〈pseudo tmpr, hardware RegisterSPL〉);
     227      sequential ertl_params_ … (CLEAR_CARRY …);
     228      sequential ertl_params_ … (OP2 … Sub addr1 tmpr addr1);
     229      sequential ertl_params_ … (MOVE … 〈pseudo tmpr, hardware RegisterSPH〉);
     230      sequential ertl_params_ … (INT … addr2 (zero ?));
     231      sequential ertl_params_ … (OP2 … Sub addr2 tmpr addr2);
     232      sequential ertl_params_ … (STORE … addr1 addr2 srcr)
    419233    ] start_lbl dest_lbl def.   
    420234
    421235definition set_params_stack ≝
    422   λparams.
     236  λglobals,params.
    423237  match params with
    424   [ nil ⇒ [ λstart_lbl. adds_graph [ertl_st_skip start_lbl] start_lbl]
     238  [ nil ⇒ [ λstart_lbl. adds_graph ertl_params1 globals [GOTO …] start_lbl]
    425239  | _ ⇒
    426     let f ≝ λi. λr. set_param_stack (bitvector_of_nat ? i) r in
    427       mapi ? ? f params
    428   ].
    429 
    430 axiom min_fst:
    431   ∀m, n: nat.
    432     min m n ≤ m.
     240    let f ≝ λi. λr. set_param_stack … (bitvector_of_nat ? i) r in
     241      mapi ? ? f params].
    433242
    434243definition set_params ≝
    435   λparams.
     244  λglobals,params.
    436245  let n ≝ min (|params|) (|RegisterParams|) in
    437246  let hdw_stack_params ≝ split ? params n ? in
    438247  let hdw_params ≝ \fst hdw_stack_params in
    439248  let stack_params ≝ \snd hdw_stack_params in
    440     set_params_hdw hdw_params @ set_params_stack stack_params.
    441   @min_fst
     249    set_params_hdw globals hdw_params @ set_params_stack globals stack_params.
     250/2/
    442251qed.
    443252
    444253definition fetch_result ≝
     254  λglobals.
    445255  λret_regs.
    446256  λstart_lbl: label.
     
    449259    let commonl ≝ \fst (\fst crl) in
    450260    let commonr ≝ \fst (\snd crl) in
    451     let f_save ≝ λst. λret. ertl_st_hdw_to_hdw st ret start_lbl in
     261    let f_save ≝ λst. λret. sequential ertl_params_ globals (MOVE … 〈hardware st, hardware ret〉) in
    452262    let saves ≝ map2 ? ? ? f_save commonl commonr ? in
    453263    match reduce_strong ? ? ret_regs RegisterSTS with
     
    455265      let commonl ≝ \fst (\fst crl) in
    456266      let commonr ≝ \fst (\snd crl) in
    457       let f_restore ≝ λr. λst. ertl_st_get_hdw r st start_lbl in
     267      let f_restore ≝ λr. λst. sequential ertl_params_ … (MOVE … 〈pseudo r, hardware st〉) in
    458268      let restores ≝ map2 ? ? ? f_restore commonl commonr ? in
    459         adds_graph (saves @ restores) start_lbl
    460     ]
    461   ].
    462   [ normalize nodelta; @second_crl_proof
    463   | @first_crl_proof
    464   ]
     269        adds_graph ertl_params1 … (saves @ restores) start_lbl]].
     270[@second_crl_proof | @first_crl_proof]
    465271qed.
    466272
    467273definition translate_call_id ≝
    468   λf.
     274  λglobals,f.
    469275  λargs.
    470276  λret_regs.
     
    473279  λdef.
    474280  let nb_args ≝ |args| in
    475     add_translates (
    476       set_params args @ [
    477       adds_graph [ ertl_st_call_id f nb_args start_lbl ];
    478       fetch_result ret_regs
     281    add_translates ertl_params1 globals (
     282      set_params args @ [
     283      adds_graph ertl_params1 … [ sequential ertl_params_ … (CALL_ID … f nb_args it) ];
     284      fetch_result ret_regs
    479285      ]
    480286    ) start_lbl dest_lbl def.
    481287
    482 definition translate_stmt ≝
     288definition translate_stmt :
     289 ∀globals: list ident. label → rtlntc_statement globals → ertl_internal_function globals → ertl_internal_function globals
     290 ≝
     291  λglobals.
    483292  λlbl.
    484293  λstmt.
    485294  λdef.
    486295  match stmt with
    487   [ rtl_st_skip lbl' ⇒ add_graph lbl (ertl_st_skip lbl') def
    488   | rtl_st_cost cost_lbl lbl' ⇒ add_graph lbl (ertl_st_cost cost_lbl lbl') def
    489   | rtl_st_addr r1 r2 x lbl' ⇒ add_graph lbl (ertl_st_addr r1 r2 x lbl') def
    490   | rtl_st_stack_addr r1 r2 lbl' ⇒
    491     adds_graph [
    492       ertl_st_get_hdw r1 RegisterSPL lbl;
    493       ertl_st_get_hdw r2 RegisterSPH lbl
    494     ] lbl lbl' def
    495   | rtl_st_int r i lbl' ⇒  add_graph lbl (ertl_st_int r i lbl') def
    496   | rtl_st_move r1 r2 lbl' ⇒ add_graph lbl (ertl_st_move r1 r2 lbl') def
    497   | rtl_st_opaccs op destr1 destr2 srcr1 srcr2 lbl' ⇒
    498       add_graph lbl (ertl_st_opaccs op destr1 destr2 srcr1 srcr2 lbl) def
    499 (* XXX: change from o'caml
    500     adds_graph [
    501       ertl_st_opaccs_a op destr1 srcr1 srcr2 lbl;
    502       ertl_st_opaccs_b op destr2 srcr1 srcr2 lbl
    503       ] lbl lbl' def
    504 *)
    505   | rtl_st_op1 op1 destr srcr lbl' ⇒
    506     add_graph lbl (ertl_st_op1 op1 destr srcr lbl') def
    507   | rtl_st_op2 op2 destr srcr1 srcr2 lbl' ⇒
    508     add_graph lbl (ertl_st_op2 op2 destr srcr1 srcr2 lbl') def
    509   | rtl_st_clear_carry lbl' ⇒
    510     add_graph lbl (ertl_st_clear_carry lbl') def
    511   | rtl_st_set_carry lbl' ⇒
    512     add_graph lbl (ertl_st_set_carry lbl') def
    513   | rtl_st_load destr addr1 addr2 lbl' ⇒
    514     add_graph lbl (ertl_st_load destr addr1 addr2 lbl') def
    515   | rtl_st_store addr1 addr2 srcr lbl' ⇒
    516     add_graph lbl (ertl_st_store addr1 addr2 srcr lbl') def
    517   | rtl_st_call_id f args ret_regs lbl' ⇒
    518     translate_call_id f args ret_regs lbl lbl' def
    519   | rtl_st_cond srcr lbl_true lbl_false ⇒
    520     add_graph lbl (ertl_st_cond srcr lbl_true lbl_false) def
    521   | rtl_st_return ⇒
    522     add_graph lbl ertl_st_return def
    523   | _ ⇒ ? (* assert false: not implemented or should not happen *)
    524   ].
    525   cases not_implemented
    526 qed.   
     296  [ GOTO lbl' ⇒ add_graph … lbl (GOTO … lbl') def
     297  | RETURN ⇒ add_graph … lbl (RETURN …) def
     298  | sequential seq lbl' ⇒
     299     match seq with
     300      [ PUSH _ ⇒ ⊥ (*CSC: XXXX should not be in the syntax *)
     301      | POP _  ⇒ ⊥ (*CSC: XXXX should not be in the syntax *)
     302      | CALL_ID f args ret_regs ⇒
     303         translate_call_id … f args ret_regs lbl lbl' def
     304      | MOVE rs ⇒
     305         let 〈r1,r2〉 ≝ rs in
     306         let rs ≝ 〈pseudo r1, pseudo r2〉 in
     307          add_graph ertl_params1 ? lbl (sequential … (MOVE … rs) lbl') def
     308      | extension ext ⇒
     309         match ext with
     310          [ rtlntc_st_ext_call_ptr _ _ _ _ ⇒ ⊥ (*CSC: XXXX not implemented in OCaml too *)
     311          | rtlntc_st_ext_address r1 r2 ⇒
     312             adds_graph ertl_params1 … [
     313              sequential ertl_params_ … (MOVE … 〈pseudo r1, hardware RegisterSPL〉);
     314              sequential ertl_params_ … (MOVE … 〈pseudo r2, hardware RegisterSPH〉)
     315             ] lbl lbl' def]
     316      (*CSC: everything is just copied to re-type it from now on;
     317        the problem is call_id that takes different parameters, but that is pattern-matched
     318        above. It could be made nicer at the cost of making all the rest of the code uglier *)
     319      | COST_LABEL cost_lbl ⇒ add_graph ertl_params1 … lbl (sequential … (COST_LABEL … cost_lbl) lbl') def
     320      | ADDRESS x prf r1 r2 ⇒ add_graph ertl_params1 … lbl (sequential … (ADDRESS … x prf r1 r2) lbl') def
     321      | INT r i ⇒  add_graph ertl_params1 … lbl (sequential … (INT … r i) lbl') def
     322      | OPACCS op destr1 destr2 srcr1 srcr2 ⇒
     323          add_graph ertl_params1 … lbl (sequential … (OPACCS … op destr1 destr2 srcr1 srcr2) lbl') def
     324      | OP1 op1 destr srcr ⇒
     325        add_graph ertl_params1 … lbl (sequential … (OP1 … op1 destr srcr) lbl') def
     326      | OP2 op2 destr srcr1 srcr2 ⇒
     327        add_graph ertl_params1 … lbl (sequential … (OP2 … op2 destr srcr1 srcr2) lbl') def
     328      | CLEAR_CARRY ⇒
     329        add_graph ertl_params1 … lbl (sequential … (CLEAR_CARRY …) lbl') def
     330      | SET_CARRY ⇒
     331        add_graph ertl_params1 … lbl (sequential … (SET_CARRY …) lbl') def
     332      | LOAD destr addr1 addr2 ⇒
     333        add_graph ertl_params1 … lbl (sequential … (LOAD … destr addr1 addr2) lbl') def
     334      | STORE addr1 addr2 srcr ⇒
     335        add_graph ertl_params1 … lbl (sequential … (STORE … addr1 addr2 srcr) lbl') def
     336      | COND srcr lbl_true ⇒
     337        add_graph ertl_params1 … lbl (sequential … (COND … srcr lbl_true) lbl') def
     338      | COMMENT msg ⇒
     339        add_graph ertl_params1 … lbl (sequential … (COMMENT … msg) lbl') def
     340      ]].
     341  @not_implemented (*CSC: XXXX spurious things in the syntax and ptr_calls *)
     342qed.
    527343
    528344(* hack with empty graphs used here *)
    529345definition translate_funct_internal ≝
    530   λdef.
    531   let nb_params ≝ |rtl_if_params def| in
     346  λglobals.λdef:rtlntc_internal_function globals.
     347  let nb_params ≝ |joint_if_params ?? def| in
    532348  let added_stacksize ≝ max 0 (nb_params - |RegisterParams|) in
    533   let new_locals ≝ nub_by ? (eq_identifier ?) ((rtl_if_locals def) @ (rtl_if_params def)) in
    534   let entry' ≝ rtl_if_entry def in
    535   let exit' ≝ rtl_if_exit def in
    536   let graph' ≝ add ? ? (empty_map ? ?) entry' (ertl_st_skip entry') in
    537   let graph' ≝ add ? ? graph' exit' (ertl_st_skip exit') in
     349  let new_locals ≝ nub_by ? (eq_identifier ?) ((joint_if_locals … def) @ (joint_if_params … def)) in
     350  let entry' ≝ joint_if_entry … def in
     351  let exit' ≝ joint_if_exit … def in
     352  let graph' ≝ add ? ? (empty_map ? ?) entry' (GOTO … entry') in
     353  let graph' ≝ add ? ? graph' exit' (GOTO … exit') in
    538354  let def' ≝
    539     mk_ertl_internal_function
    540       (rtl_if_luniverse def) (rtl_if_runiverse def)
    541       nb_params new_locals ((rtl_if_stacksize def) + added_stacksize)
     355    mk_joint_internal_function globals (ertl_params globals)
     356      (joint_if_luniverse … def) (joint_if_runiverse … def) it
     357      nb_params new_locals ((joint_if_stacksize … def) + added_stacksize)
    542358      graph' ? ? in
    543   let def' ≝ foldi ? ? ? translate_stmt (rtl_if_graph def) def' in
    544   let def' ≝ add_pro_and_epilogue (rtl_if_params def) (rtl_if_result def) def' in
    545     def'.
    546   [1: %
    547       [1: @entry'
    548       |2: normalize nodelta
    549           @graph_add_lookup
    550           @graph_add
    551       ]
    552   |2: %
    553       [1: @exit'
    554       |2: normalize nodelta
    555           @graph_add
    556       ]
     359  let def' ≝ foldi ? ? ? (translate_stmt globals) (joint_if_code … def) def' in
     360   add_pro_and_epilogue ? (joint_if_params ?? def) (joint_if_result ?? def) def'.
     361whd in match ertl_params (* CSC: Matita's bug here; not enough/too much reduction
     362                                 makes the next application fail. Why? *)   
     363%
     364 [ @entry' | @graph_add_lookup @graph_add
     365 | @exit'  | @graph_add ]
     366qed.
     367
     368definition generate ≝
     369  λglobals.
     370  λstmt.
     371  λdef: joint_internal_function … (ertl_params globals).
     372  let 〈entry, def〉 ≝ fresh_label … def in
     373  let graph ≝ add … (joint_if_code … def) entry stmt in
     374   set_joint_if_graph … (ertl_params globals) graph def ??.
     375  [ (*% [ @entry | @graph_add ]*) cases daemon (*CSC: XXX *)
     376  | (*cases (joint_if_exit … def) #LBL #LBL_PRF % [ @LBL | @graph_add_lookup @LBL_PRF
     377    *) cases daemon (*CSC: XXX *)
    557378  ]
    558379qed.
    559    
    560 definition translate_funct ≝
    561   λid_def: ident × ?.
    562   let 〈id, def〉 ≝ id_def in
    563   let def' ≝
    564     match def with
    565     [ Internal def ⇒ Internal ? (translate_funct_internal def)
    566     | External def ⇒ External ? def
    567     ] in
    568   〈id, def'〉.
    569 
    570 definition generate ≝
    571   λstmt.
    572   λdef.
    573   let 〈entry, nuniv〉 ≝ fresh_label def in
    574   let graph ≝ add ? ? (ertl_if_graph def) entry stmt in
    575     mk_ertl_internal_function
    576       nuniv (ertl_if_runiverse def) (ertl_if_params def)
    577       (ertl_if_locals def) (ertl_if_stacksize def) graph
    578       ? ?.
    579   [1: %
    580     [1: @entry
    581     |2: normalize nodelta;
    582         @graph_add
    583     ]
    584   |2: generalize in match (ertl_if_exit def)
    585       #HYP
    586       cases HYP
    587       #LBL #LBL_PRF
    588       %
    589       [1: @LBL
    590       |2: normalize nodelta;
    591           @graph_add_lookup
    592           @LBL_PRF
    593       ]
    594   ]
    595 qed.
    596    
    597 let rec find_and_remove_first_cost_label_internal
    598   (def: ertl_internal_function) (lbl: label) (num_nodes: nat)
     380
     381let rec find_and_remove_first_cost_label_internal (globals: list ident)
     382  (def: ertl_internal_function globals) (lbl: label) (num_nodes: nat)
    599383    on num_nodes ≝
    600384  match num_nodes with
    601385  [ O ⇒ 〈None ?, def〉
    602386  | S num_nodes' ⇒
    603     match lookup ? ? (ertl_if_graph def) lbl with
     387    match lookup … (joint_if_code … def) lbl with
    604388    [ None ⇒ 〈None ?, def〉
    605     | Some stmt ⇒
     389    | Some stmt ⇒ 
    606390      match stmt with
    607       [ ertl_st_cost cost_lbl next_lbl ⇒
    608           〈Some ? cost_lbl, add_graph lbl (ertl_st_skip next_lbl) def〉
    609       | ertl_st_cond _ _ _ ⇒ 〈None ?, def〉
    610       | ertl_st_return ⇒ 〈None ?, def〉
    611       | ertl_st_skip lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    612       | ertl_st_comment _ lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    613       | ertl_st_get_hdw _ _ lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    614       | ertl_st_set_hdw _ _ lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    615       | ertl_st_hdw_to_hdw _ _ lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    616       | ertl_st_pop _ lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    617       | ertl_st_push _ lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    618       | ertl_st_addr _ _ _ lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    619       | ertl_st_int _ _ lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    620       | ertl_st_move _ _ lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    621       | ertl_st_opaccs _ _ _ _ _ lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    622       | ertl_st_op1 _ _ _ lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    623       | ertl_st_op2 _ _ _ _ lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    624       | ertl_st_clear_carry lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    625       | ertl_st_set_carry lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    626       | ertl_st_load _ _ _ lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    627       | ertl_st_store _ _ _ lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    628       | ertl_st_call_id _ _ lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    629       | ertl_st_new_frame lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    630       | ertl_st_del_frame lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    631       | ertl_st_frame_size _ lbl ⇒ find_and_remove_first_cost_label_internal def lbl num_nodes'
    632       ]
    633     ]
    634   ].
     391      [ sequential inst lbl ⇒
     392         match inst with
     393          [ COST_LABEL cost_lbl ⇒
     394             〈Some … cost_lbl, add_graph ertl_params1 globals lbl (GOTO … lbl) def〉
     395          | _ ⇒ find_and_remove_first_cost_label_internal globals def lbl num_nodes' ]
     396      | RETURN ⇒ 〈None …, def〉
     397      | GOTO lbl ⇒ find_and_remove_first_cost_label_internal globals def lbl num_nodes'
     398      ]]].
    635399   
    636400definition find_and_remove_first_cost_label ≝
    637   λdef. 
    638     find_and_remove_first_cost_label_internal def (ertl_if_entry def) (graph_num_nodes ? (ertl_if_graph def)).
     401  λglobals,def. 
     402    find_and_remove_first_cost_label_internal globals def (joint_if_entry … def) (graph_num_nodes ? (joint_if_code … def)).
    639403
    640404definition move_first_cost_label_up_internal ≝
    641   λdef.
    642   let 〈cost_label, def〉 ≝ find_and_remove_first_cost_label def in
     405  λglobals,def.
     406  let 〈cost_label, def〉 ≝ find_and_remove_first_cost_label def in
    643407  match cost_label with
    644408  [ None ⇒ def
    645   | Some cost_label ⇒ generate (ertl_st_cost cost_label (ertl_if_entry def)) def
     409  | Some cost_label ⇒ generate … (sequential ertl_params_ globals (COST_LABEL … cost_label) (joint_if_entry … def)) def
    646410  ].
    647411
    648 definition move_first_cost_label_up ≝
    649   λA: Type[0].
    650   λid_def: A × ?.
    651   let 〈id, def〉 ≝ id_def in
    652   let def' ≝
    653     match def with
    654     [ Internal int_fun ⇒ Internal ? (move_first_cost_label_up_internal int_fun)
    655     | External ext ⇒ def
    656     ]
    657   in
    658     〈id, def'〉.
    659 
    660 definition translate ≝
    661   λp.
     412definition translate_funct ≝ λglobals,def. (move_first_cost_label_up_internal … (translate_funct_internal globals def)).
     413
     414definition translate : rtl_program → ertl_program ≝
     415 λp.
    662416  let p ≝ tailcall_simplify p in (* tailcall simplification here *)
    663   let f ≝ λfunct. move_first_cost_label_up ? (translate_funct funct) in
    664   let vars ≝ map ? ? f (rtl_pr_functs p) in
    665     mk_ertl_program (rtl_pr_vars p) vars (rtl_pr_main p).
     417    transform_program ??? p (transf_fundef ?? (translate_funct …)).
  • Deliverables/D3.3/id-lookup-branch/RTL/semantics.ma

    r1153 r1311  
    264264     [ nil ⇒ Some ? (smerge2 v)
    265265     | _ ⇒ None ? ]].
    266 
     266(*
    267267definition RTL_exec : execstep io_out io_in ≝
    268268  mk_execstep … ? is_final mem_of_state eval_statement.
    269 
     269*)
    270270(* CSC: XXX the program type does not fit with the globalenv and init_mem
    271271definition make_initial_state : rtl_program → res (genv × state) ≝
  • Deliverables/D3.3/id-lookup-branch/RTLabs/RTLAbstoRTL.ma

    r1077 r1311  
    44include "common/FrontEndOps.ma".
    55include "common/Graphs.ma".
    6 
    7 definition add_graph ≝
    8   λl: label.
    9   λstmt.
    10   λp.
    11   let rtl_if_luniverse' ≝ rtl_if_luniverse p in
    12   let rtl_if_runiverse' ≝ rtl_if_runiverse p in
    13   let rtl_if_result' ≝ rtl_if_result p in
    14   let rtl_if_params' ≝ rtl_if_params p in
    15   let rtl_if_locals' ≝ rtl_if_locals p in
    16   let rtl_if_stacksize' ≝ rtl_if_stacksize p in
    17   let rtl_if_graph' ≝ add ? ? (rtl_if_graph p) l stmt in
    18   let rtl_if_entry' ≝ rtl_if_entry p in
    19   let rtl_if_exit' ≝ rtl_if_exit p in
    20     mk_rtl_internal_function rtl_if_luniverse' rtl_if_runiverse'
    21                              rtl_if_params' rtl_if_params' rtl_if_locals'
    22                              rtl_if_stacksize' rtl_if_graph' ? ?.
    23   [1: cases(rtl_if_entry')
    24       #LABEL #HYP %
    25       [1: @LABEL
    26       |2: cases(HYP)
    27           generalize in match (graph_add_lookup ? (rtl_if_graph p) LABEL stmt l);
    28           normalize nodelta;
    29           /2/
    30       ]
    31   |2: cases(rtl_if_exit')
    32       #LABEL #HYP %
    33       [1: @LABEL
    34       |2: cases(HYP)
    35           generalize in match (graph_add_lookup ? (rtl_if_graph p) LABEL stmt l);
    36           normalize nodelta;
    37           /2/
    38       ]
    39   ]
    40 qed.
    41      
    42 definition fresh_label: rtl_internal_function → rtl_internal_function × label ≝
    43   λdef.
    44     let 〈lbl, new_univ〉 ≝ fresh LabelTag (rtl_if_luniverse def) in
    45     let locals ≝ rtl_if_locals def in
    46     let rtl_if_luniverse' ≝ new_univ in
    47     let rtl_if_runiverse' ≝ rtl_if_runiverse def in
    48     let rtl_if_result' ≝ rtl_if_result def in
    49     let rtl_if_params' ≝ rtl_if_params def in
    50     let rtl_if_locals' ≝ rtl_if_locals def in
    51     let rtl_if_stacksize' ≝ rtl_if_stacksize def in
    52     let rtl_if_graph' ≝ rtl_if_graph def in
    53     let rtl_if_entry' ≝ rtl_if_entry def in
    54     let rtl_if_exit' ≝ rtl_if_exit def in
    55       〈mk_rtl_internal_function
    56         rtl_if_luniverse' rtl_if_runiverse' rtl_if_result'
    57         rtl_if_params' rtl_if_locals' rtl_if_stacksize' rtl_if_graph'
    58         rtl_if_entry' rtl_if_exit', lbl〉.
    59 
    60 axiom register_fresh: universe RegisterTag → register.
    61 
    62 definition fresh_reg: rtl_internal_function → rtl_internal_function × register ≝
    63   λdef.
    64     let r ≝ register_fresh (rtl_if_runiverse def) in
    65     let locals ≝ r :: rtl_if_locals def in
    66     let rtl_if_luniverse' ≝ rtl_if_luniverse def in
    67     let rtl_if_runiverse' ≝ rtl_if_runiverse def in
    68     let rtl_if_result' ≝ rtl_if_result def in
    69     let rtl_if_params' ≝ rtl_if_params def in
    70     let rtl_if_locals' ≝ locals in
    71     let rtl_if_stacksize' ≝ rtl_if_stacksize def in
    72     let rtl_if_graph' ≝ rtl_if_graph def in
    73     let rtl_if_entry' ≝ rtl_if_entry def in
    74     let rtl_if_exit' ≝ rtl_if_exit def in
    75       〈mk_rtl_internal_function
    76         rtl_if_luniverse' rtl_if_runiverse' rtl_if_result'
    77         rtl_if_params' rtl_if_locals' rtl_if_stacksize' rtl_if_graph'
    78         rtl_if_entry' rtl_if_exit', r〉.
    79        
    80 let rec fresh_regs (def: rtl_internal_function) (n: nat) on n ≝
    81   match n with
    82   [ O   ⇒ 〈def, [ ]〉
    83   | S n ⇒
    84     let 〈def, res〉 ≝ fresh_regs def n in
    85     let 〈def, r〉 ≝ fresh_reg def in
    86       〈def, r :: res〉
    87   ].
    88 
    89 axiom fresh_regs_length:
    90   ∀def: rtl_internal_function.
    91   ∀n: nat.
    92     |(\snd (fresh_regs def n))| = n.
    93    
    94 definition addr_regs ≝
    95   λregs.
    96   match regs with
    97   [ cons hd tl ⇒
    98     match tl with
    99     [ cons hd' tl' ⇒ Some (register × register) 〈hd, hd'〉
    100     | nil          ⇒ None (register × register)
    101     ]
    102   | nil ⇒ None (register × register) (* registers are not an address *)
    103   ].
     6include "joint/TranslateUtils.ma".
    1047
    1058let rec register_freshes (runiverse: universe RegisterTag) (n: nat) on n ≝
    1069  match n with
    107   [ O ⇒ [ ]
    108   | S n' ⇒ register_fresh runiverse :: (register_freshes runiverse n')
    109   ].
     10  [ O ⇒ 〈[],runiverse〉
     11  | S n' ⇒
     12     let 〈r,runiverse〉 ≝ fresh … runiverse in
     13     let 〈res,runiverse〉 ≝ register_freshes runiverse n' in
     14      〈r::res,runiverse〉 ].
    11015
    11116definition choose_rest ≝
     
    12934
    13035definition complete_regs ≝
     36  λglobals.
    13137  λdef.
    13238  λsrcrs1.
    13339  λsrcrs2.
    134   let nb_added ≝ abs ((length ? srcrs1) - (length ? srcrs2)) in
    135   let 〈def, added_regs〉 ≝ fresh_regs def nb_added in
    136     if gtb nb_added 0 then
    137       〈〈srcrs1, srcrs2 @ added_regs〉, added_regs〉
    138     else
    139       〈〈srcrs1 @ added_regs, srcrs2〉, added_regs〉.
    140 
    141 (* obvious, but proof doesn't look easy! *)
    142 axiom complete_regs_length:
    143   ∀def.
    144   ∀left.
    145   ∀right.
    146     |\fst (\fst (complete_regs def left right))| = |\snd (\fst (complete_regs def left right))|.
     40  if leb (length … srcrs2) (length … srcrs1) then
     41   let 〈def, added_regs〉 ≝ fresh_regs rtl_params0 globals def (minus (length ? srcrs1) (length ? srcrs2)) in
     42    〈〈srcrs1, srcrs2 @ added_regs〉, added_regs〉
     43  else
     44   let 〈def, added_regs〉 ≝ fresh_regs rtl_params0 globals def (minus (length ? srcrs2) (length ? srcrs1)) in
     45    〈〈srcrs1 @ added_regs, srcrs2〉, added_regs〉.
     46
     47lemma complete_regs_length:
     48  ∀globals,def,left,right.
     49   |\fst (\fst (complete_regs globals def left right))| = |\snd (\fst (complete_regs globals def left right))|.
     50 #globals #def #left #right
     51 whd in match complete_regs normalize nodelta
     52 @leb_elim normalize nodelta #H
     53 [ generalize in match (fresh_regs_length rtl_params0 globals def (minus (length … left) (length … right)))
     54 | generalize in match (fresh_regs_length rtl_params0 globals def (minus (length … right) (length … left)))]
     55 cases (fresh_regs ????) #def' #fresh normalize >append_length
     56 generalize in match H -H;
     57 generalize in match (length … left) generalize in match (length … right) generalize in match (length … fresh)
     58 [ /2/ | #x #y #z #H generalize in match (not_le_to_lt … H) -H #H #E >E >commutative_plus
     59         <plus_minus_m_m /2/ ]
     60qed.
    14761
    14862definition size_of_sig_type ≝
     
    16276  | register_ptr: register → register → register_type.
    16377
    164 definition local_env ≝ BitVectorTrie (list register).
    165 
    166 definition mem_local_env ≝
    167   λr: register.
    168   match r with
    169   [ an_identifier w ⇒ member (list register) 16 w
    170   ].
    171 
    172 definition add_local_env ≝
    173   λr: register.
    174   match r with
    175   [ an_identifier w ⇒ insert (list register) 16 w
    176   ].
    177 
    178 definition find_local_env ≝
    179   λr: register.
    180   λbvt.
    181   match r with
    182   [ an_identifier w ⇒ lookup (list register) 16 w bvt [ ]
    183   ].
     78definition local_env ≝ BitVectorTrie (list register) 16.
     79
     80definition mem_local_env : register → local_env → bool ≝
     81  λr. member … (word_of_identifier … r).
     82
     83definition add_local_env : register → list register → local_env → local_env ≝
     84  λr. insert … (word_of_identifier … r).
     85
     86definition find_local_env : register → local_env → list register ≝
     87  λr: register.λbvt. lookup … (word_of_identifier … r) bvt [].
    18488
    18589definition initialize_local_env_internal ≝
    186   λruniverse.
    187   λlenv.
     90  λlenv_runiverse.
    18891  λr_sig.
     92  let 〈lenv,runiverse〉 ≝ lenv_runiverse in
    18993  let 〈r, sig〉 ≝ r_sig in
    19094  let size ≝ size_of_sig_type sig in
    191   let rs ≝ register_freshes runiverse size in
    192     add_local_env r rs lenv.
     95  let 〈rs,runiverse〉 ≝ register_freshes runiverse size in
     96    〈add_local_env r rs lenv,runiverse〉.
    19397
    19498definition initialize_local_env ≝
     
    202106    ]
    203107  in
    204     foldl ? ? (initialize_local_env_internal runiverse) (Stub …) registers.
    205  
     108    foldl ? ? initialize_local_env_internal 〈Stub …,runiverse〉 registers.
     109
    206110definition map_list_local_env_internal ≝
    207   λlenv.
    208   λres.
    209   λr.
    210     res @ (find_local_env r lenv).
     111  λlenv,res,r. res @ (find_local_env r lenv).
    211112   
    212113definition map_list_local_env ≝
    213   λlenv.
    214   λregs.
    215     foldl ? ? (map_list_local_env_internal lenv) [ ] regs.
     114  λlenv,regs. foldl … (map_list_local_env_internal lenv) [ ] regs.
    216115
    217116definition make_addr ≝
     
    235134  |3: normalize in tl_nil_prf;
    236135      cases(not_le_Sn_O 0)
    237       #HYP cases(HYP tl_nil_prf)
    238   ]
     136      #HYP cases(HYP tl_nil_prf)]
    239137qed.
    240138
    241139definition find_and_addr ≝
    242   λr.
    243   λlenv.
    244     make_addr ? (find_local_env r lenv).
     140  λr,lenv. make_addr ? (find_local_env r lenv).
    245141
    246142definition rtl_args ≝
    247   λregs_list.
    248   λlenv.
    249     flatten ? (map ? ? (
    250       λr. find_local_env r lenv) regs_list).
    251 
    252 definition change_label ≝
    253   λlbl.
    254   λstmt: rtl_statement.
    255   match stmt with
    256   [ rtl_st_skip _ ⇒ rtl_st_skip lbl
    257   | rtl_st_cost cost_lbl _ ⇒ rtl_st_cost cost_lbl lbl
    258   | rtl_st_addr r1 r2 id _ ⇒ rtl_st_addr r1 r2 id lbl
    259   | rtl_st_stack_addr r1 r2 _ ⇒ rtl_st_stack_addr r1 r2 lbl
    260   | rtl_st_int r i _ ⇒ rtl_st_int r i lbl
    261   | rtl_st_move r1 r2 _ ⇒ rtl_st_move r1 r2 lbl
    262   | rtl_st_opaccs opaccs d s1 s2 s3 _ ⇒ rtl_st_opaccs opaccs d s1 s2 s3 lbl
    263   | rtl_st_op1 op1 d s _ ⇒ rtl_st_op1 op1 d s lbl
    264   | rtl_st_op2 op2 d s1 s2 _ ⇒ rtl_st_op2 op2 d s1 s2 lbl
    265   | rtl_st_load d a1 a2 _ ⇒ rtl_st_load d a1 a2 lbl
    266   | rtl_st_store a1 a2 s _ ⇒ rtl_st_store a1 a2 s lbl
    267   | rtl_st_call_id f a r _ ⇒ rtl_st_call_id f a r lbl
    268   | rtl_st_call_ptr f1 f2 a r _ ⇒ rtl_st_call_ptr f1 f2 a r lbl
    269   | rtl_st_tailcall_id f a ⇒ rtl_st_tailcall_id f a
    270   | rtl_st_tailcall_ptr f1 f2 a ⇒ rtl_st_tailcall_ptr f1 f2 a
    271   | rtl_st_cond r l1 l2 ⇒ rtl_st_cond r l1 l2
    272   | rtl_st_clear_carry l ⇒ rtl_st_clear_carry lbl
    273   | rtl_st_set_carry l ⇒ rtl_st_set_carry lbl
    274   | rtl_st_return ⇒ rtl_st_return
    275   ].
    276 
    277 (* Ack! Should generating a fresh label ever fail?  This seems to be a side-effect
    278    of implementing everything as a bitvector, which is bounded.  If we implemented
    279    labels as unbounded nats then this function will never fail.
    280 *)
    281 (* Fixed with changes to label generation.
    282 *)
    283 let rec adds_graph (stmt_list: ?) (start_lbl: label) (dest_lbl: label) (def: rtl_internal_function) ≝
    284   match stmt_list with
    285   [ nil ⇒ def
    286   | cons hd tl ⇒
    287     match tl with
    288     [ nil ⇒ add_graph start_lbl (change_label dest_lbl hd) def
    289     | cons hd' tl' ⇒
    290       let 〈new_def, tmp_lbl〉 ≝ fresh_label def in
    291       let stmt ≝ change_label tmp_lbl hd in
    292       let def ≝ add_graph start_lbl stmt new_def in
    293         adds_graph tl tmp_lbl dest_lbl new_def
    294     ]
    295   ].
    296 
    297 let rec add_translates (translate_list: ?) (start_lbl: label) (dest_lbl: label)
    298                        (def: ?) on translate_list ≝
    299   match translate_list with
    300   [ nil ⇒ def
    301   | cons hd tl ⇒
    302     match tl with
    303     [ nil ⇒ hd start_lbl dest_lbl def
    304     | cons hd' tl' ⇒
    305       let 〈new_def, tmp_lbl〉 ≝ fresh_label def in
    306       let applied ≝ hd start_lbl tmp_lbl new_def in
    307         add_translates tl tmp_lbl dest_lbl applied
    308     ]
    309   ].
     143  λregs_list,lenv. flatten … (map … (λr. find_local_env r lenv) regs_list).
    310144
    311145definition translate_cst_int_internal ≝
    312   λdest_lbl.
    313   λr.
    314   λi.
    315     rtl_st_int r i dest_lbl.
    316 
     146  λglobals,dest_lbl,r,i. sequential rtl_params_ globals (INT … r i) dest_lbl.
     147
     148(*CSC: XXXXX *)
    317149axiom translate_cst:
     150  ∀globals.
    318151  ∀cst: constant.
    319152  ∀destrs: list register.
    320153  ∀start_lbl: label.
    321154  ∀dest_lbl: label.
    322   ∀def: rtl_internal_function.
    323     rtl_internal_function.
     155  ∀def: rtl_internal_function globals.
     156    rtl_internal_function globals.
    324157
    325158definition translate_move_internal ≝
    326   λstart_lbl: label.
     159  λglobals.
    327160  λdestr: register.
    328161  λsrcr: register.
    329     rtl_st_move destr srcr start_lbl.
     162    sequential rtl_params_ globals (MOVE … 〈destr,srcr〉).
    330163
    331164definition translate_move ≝
     165  λglobals.
    332166  λdestrs: list register.
    333167  λsrcrs: list register.
     
    339173      let restl ≝ \snd (\fst crl_crr) in
    340174      let restr ≝ \snd (\snd crl_crr) in
    341       let f_common ≝ translate_move_internal start_lbl in
    342       let translate1 ≝ adds_graph (map2 … f_common commonl commonr ?) in
    343       let translate2 ≝ translate_cst (Ointconst ? (repr I8 0)) restl in (* should this be 8? *)
    344         add_translates [ translate1 ; translate2 ] start_lbl
     175      let f_common ≝ translate_move_internal globals in
     176      let translate1 ≝ adds_graph rtl_params1 … (map2 … f_common commonl commonr ?) in
     177      let translate2 ≝ translate_cst (Ointconst ? (repr I8 0)) restl in (* should this be 8? *)
     178        add_translates [ translate1 ; translate2 ] start_lbl
    345179    ].
    346180    @len_proof
     
    368202
    369203definition translate_cast_unsigned ≝
     204  λglobals.
    370205  λdestrs.
    371206  λstart_lbl.
    372207  λdest_lbl.
    373   λdef.
    374   let 〈def, tmp_zero〉 ≝ fresh_reg def in
    375   let zeros ≝ make ? tmp_zero (length ? destrs) in
    376     add_translates [
    377       adds_graph [
    378         rtl_st_int tmp_zero (bitvector_of_nat ? 0) start_lbl
     208  λdef: joint_internal_function … (rtl_params globals).
     209  let 〈def, tmp_zero〉 ≝ fresh_reg def in
     210  let zeros ≝ make … tmp_zero (length … destrs) in
     211    add_translates [
     212      adds_graph rtl_params1 … [
     213        sequential rtl_params_ … (INT rtl_params_ ? tmp_zero (bitvector_of_nat ? 0))
    379214        ];
    380       translate_move destrs zeros
     215      translate_move globals destrs zeros
    381216    ] start_lbl dest_lbl def.
    382217
    383 definition translate_cast_signed ≝
     218definition translate_cast_signed:
     219    ∀globals: list ident. list register → ? → label → label → rtl_internal_function globals → rtl_internal_function globals ≝
     220  λglobals: list ident.
    384221  λdestrs.
    385222  λsrcr.
     
    387224  λdest_lbl.
    388225  λdef.
    389   let 〈def, tmp_128〉 ≝ fresh_reg def in
    390   let 〈def, tmp_255〉 ≝ fresh_reg def in
    391   let 〈def, tmpr〉 ≝ fresh_reg def in
    392   let 〈def, dummy〉 ≝ fresh_reg def in
     226  let 〈def, tmp_128〉 ≝ fresh_reg def in
     227  let 〈def, tmp_255〉 ≝ fresh_reg def in
     228  let 〈def, tmpr〉 ≝ fresh_reg def in
     229  let 〈def, dummy〉 ≝ fresh_reg def in
    393230  let insts ≝ [
    394     rtl_st_int tmp_128 (bitvector_of_nat ? 128) start_lbl;
    395     rtl_st_op2 And tmpr tmp_128 srcr start_lbl;
    396     rtl_st_opaccs DivuModu tmpr dummy tmpr tmp_128 start_lbl;
    397     rtl_st_int tmp_255 (bitvector_of_nat ? 255) start_lbl;
    398     rtl_st_opaccs Mul tmpr dummy tmpr tmp_255 start_lbl
    399   ] in
    400   let srcrs ≝ make ? tmpr (length ? destrs) in
    401     add_translates [
    402       adds_graph insts;
    403       translate_move destrs srcrs
     231    sequential  … (INT rtl_params_ globals tmp_128 (bitvector_of_nat ? 128));
     232    sequential … (OP2 rtl_params_ globals And tmpr tmp_128 srcr);
     233    sequential … (OPACCS rtl_params_ globals DivuModu tmpr dummy tmpr tmp_128);
     234    sequential … (INT rtl_params_ globals tmp_255 (bitvector_of_nat ? 255));
     235    sequential … (OPACCS rtl_params_ globals Mul tmpr dummy tmpr tmp_255)
     236  ]
     237  in
     238  let srcrs ≝ make … tmpr (length … destrs) in
     239    add_translates rtl_params1 globals [
     240      adds_graph rtl_params1 globals insts;
     241      translate_move globals destrs srcrs
    404242    ] start_lbl dest_lbl def.
    405243
    406244definition translate_cast ≝
    407   λsrc_size.
    408   λsrc_sign.
    409   λdest_size.
    410   λdestrs.
    411   λsrcrs.
     245  λglobals: list ident.
     246  λsrc_size: nat.
     247  λsrc_sign: signedness.
     248  λdest_size: nat.
     249  λdestrs: list register.
     250  λsrcrs: list register.
    412251  match |srcrs| return λx. |srcrs| = x → ? with
    413   [ O ⇒ λzero_prf. adds_graph [ ]
     252  [ O ⇒ λzero_prf. adds_graph rtl_params1 globals [ ]
    414253  | S n' ⇒ λsucc_prf.
    415254    if ltb dest_size src_size then
    416       translate_move destrs srcrs
     255      translate_move globals destrs srcrs
    417256    else
    418257      match reduce_strong register register destrs srcrs with
     
    422261        let restl ≝ \snd (\fst crl) in
    423262        let restr ≝ \snd (\snd crl) in
    424         let insts_common ≝ translate_move commonl commonr in
     263        let insts_common ≝ translate_move globals commonl commonr in
    425264        let sign_reg ≝ last_safe ? srcrs ? in
    426265        let insts_sign ≝
    427266          match src_sign with
    428           [ Unsigned ⇒ translate_cast_unsigned restl
    429           | Signed ⇒ translate_cast_signed restl sign_reg
     267          [ Unsigned ⇒ translate_cast_unsigned globals restl
     268          | Signed ⇒ translate_cast_signed globals restl sign_reg
    430269          ]
    431270        in
    432           add_translates [ insts_common; insts_sign ]
     271          add_translates rtl_params1 globals [ insts_common; insts_sign ]
    433272      ]
    434273  ] (refl ? (|srcrs|)).
     
    437276
    438277definition translate_negint ≝
    439   λdestrs.
    440   λsrcrs.
    441   λstart_lbl.
    442   λdest_lbl.
    443   λdef.
    444   λprf: | destrs | = | srcrs |. (* assert in caml code *)
    445   let 〈def, tmpr〉 ≝ fresh_reg def in
    446   let f_cmpl ≝ λdestr. λsrcr. rtl_st_op1 Cmpl destr srcr start_lbl in
    447   let insts_cmpl ≝ map2 ? ? ? f_cmpl destrs srcrs prf in
     278  λglobals: list ident.
     279  λdestrs: list register.
     280  λsrcrs: list register.
     281  λstart_lbl: label.
     282  λdest_lbl: label.
     283  λdef: rtl_internal_function globals.
     284  λprf: |destrs| = |srcrs|. (* assert in caml code *)
     285  let 〈def, tmpr〉 ≝ fresh_reg rtl_params0 globals def in
     286  let f_cmpl ≝ λdestr. λsrcr. sequential rtl_params_ globals (OP1 rtl_params1 globals Cmpl destr srcr) in
     287  let insts_cmpl ≝ map2 … f_cmpl destrs srcrs prf in
    448288  let insts_init ≝ [
    449     rtl_st_set_carry start_lbl;
    450     rtl_st_int tmpr (zero ?) start_lbl
     289    sequential … (SET_CARRY …);
     290    sequential … (INT rtl_params_ globals tmpr (zero ?))
    451291  ] in
    452   let f_add ≝ λdestr. rtl_st_op2 Addc destr destr tmpr start_lbl in
     292  let f_add ≝ λdestr. sequential … (OP2 rtl_params_ globals Addc destr destr tmpr) in
    453293  let insts_add ≝ map … f_add destrs in
    454     adds_graph (insts_cmpl @ insts_init @ insts_add) start_lbl dest_lbl def.
    455 
    456 definition translate_notbool ≝
    457   λdestrs.
    458   λsrcrs.
    459   λstart_lbl.
    460   λdest_lbl.
    461   λdef.
     294    adds_graph rtl_params1 globals (insts_cmpl @ insts_init @ insts_add) start_lbl dest_lbl def.
     295
     296definition translate_notbool: ∀globals. list register → list register → label → label → rtl_internal_function globals → rtl_internal_function globals ≝
     297  λglobals: list ident.
     298  λdestrs: list register.
     299  λsrcrs: list register.
     300  λstart_lbl: label.
     301  λdest_lbl: label.
     302  λdef: rtl_internal_function globals.
    462303  match destrs with
    463   [ nil ⇒ add_graph start_lbl (rtl_st_skip dest_lbl) def
     304  [ nil ⇒ add_graph rtl_params1 globals start_lbl (GOTO … start_lbl) def
    464305  | cons destr destrs ⇒
    465     let 〈def, tmpr〉 ≝ fresh_reg def in
    466     let 〈def, tmp_srcrs〉 ≝ fresh_regs def (length ? srcrs) in
    467     let save_srcrs ≝ translate_move tmp_srcrs srcrs in
    468     let init_destr ≝ rtl_st_int destr (bitvector_of_nat ? 1) start_lbl in
     306    let 〈def, tmpr〉 ≝ fresh_reg rtl_params0 globals def in
     307    let 〈def, tmp_srcrs〉 ≝ fresh_regs rtl_params0 globals def (length ? srcrs) in
     308    let save_srcrs ≝ translate_move globals tmp_srcrs srcrs in
     309    let init_destr ≝ sequential … (INT rtl_params_ globals destr (bitvector_of_nat ? 1)) in
    469310    let f ≝ λtmp_srcr. [
    470       rtl_st_clear_carry start_lbl;
    471       rtl_st_int tmpr (zero ?) start_lbl;
    472       rtl_st_op2 Sub tmpr tmpr tmp_srcr start_lbl;
    473       rtl_st_int tmpr (zero ?) start_lbl;
    474       rtl_st_op2 Addc tmpr tmpr tmpr start_lbl;
    475       rtl_st_op2 Xor destr destr tmpr start_lbl
     311      sequential … (CLEAR_CARRY rtl_params_ globals);
     312      sequential … (INT rtl_params_ globals tmpr (zero ?));
     313      sequential … (OP2 rtl_params_ globals Sub tmpr tmpr tmp_srcr);
     314      sequential … (INT rtl_params_ globals tmpr (zero ?));
     315      sequential … (OP2 rtl_params_ globals Addc tmpr tmpr tmpr);
     316      sequential … (OP2 rtl_params_ globals Xor destr destr tmpr)
    476317    ] in
    477     let insts ≝ init_destr :: (flatten ? (map … f tmp_srcrs)) in
    478     let epilogue ≝ translate_cst (Ointconst I8 (bitvector_of_nat ? 0)) destrs in
    479       add_translates [
    480         save_srcrs; adds_graph insts; epilogue
     318    let insts ≝ init_destr :: (flatten (map … f tmp_srcrs)) in
     319    let epilogue ≝ translate_cst globals (Ointconst I8 (zero …)) destrs in
     320      add_translates rtl_params1 globals [
     321        save_srcrs; adds_graph rtl_params1 globals insts; epilogue
    481322      ] start_lbl dest_lbl def
    482323  ].
     
    488329*)
    489330definition translate_op1 ≝
     331  λglobals: list ident.
    490332  λop1: unary_operation.
    491333  λdestrs: list register.
     
    494336  λstart_lbl: label.
    495337  λdest_lbl: label.
    496   λdef: rtl_internal_function.
     338  λdef: rtl_internal_function globals.
    497339  match op1 with
    498340  [ Ocastint src_sign src_size ⇒
    499341    let dest_size ≝ |destrs| * 8 in
    500342    let src_size ≝ bitsize_of_intsize src_size in
    501       translate_cast src_size src_sign dest_size destrs srcrs start_lbl dest_lbl def
     343      translate_cast globals src_size src_sign dest_size destrs srcrs start_lbl dest_lbl def
    502344  | Onegint ⇒
    503       translate_negint destrs srcrs start_lbl dest_lbl def prf
     345      translate_negint globals destrs srcrs start_lbl dest_lbl def prf
    504346  | Onotbool ⇒
    505       translate_notbool destrs srcrs start_lbl dest_lbl def
     347      translate_notbool globals destrs srcrs start_lbl dest_lbl def
    506348  | Onotint ⇒
    507     let f ≝ λdestr. λsrcr. rtl_st_op1 Cmpl destr srcr start_lbl in
     349    let f ≝ λdestr. λsrcr. sequential rtl_params_ globals (OP1 … Cmpl destr srcr) in
    508350    let l ≝ map2 … f destrs srcrs prf in
    509       adds_graph l start_lbl dest_lbl def
     351      adds_graph rtl_params1 globals l start_lbl dest_lbl def
    510352  | Optrofint r ⇒
    511       translate_move destrs srcrs start_lbl dest_lbl def
     353      translate_move globals destrs srcrs start_lbl dest_lbl def
    512354  | Ointofptr r ⇒
    513       translate_move destrs srcrs start_lbl dest_lbl def
     355      translate_move globals destrs srcrs start_lbl dest_lbl def
    514356  | Oid ⇒
    515       translate_move destrs srcrs start_lbl dest_lbl def
     357      translate_move globals destrs srcrs start_lbl dest_lbl def
    516358  | _ ⇒ ? (* float operations implemented in runtime *)
    517359  ].
     
    519361qed.
    520362 
    521 definition translate_op ≝
     363definition translate_op: ∀globals. ? → list register → list register → list register →
     364  label → label → rtl_internal_function globals → rtl_internal_function globals ≝
     365  λglobals: list ident.
    522366  λop.
    523   λdestrs.
    524   λsrcrs1.
    525   λsrcrs2.
    526   λstart_lbl.
    527   λdest_lbl.
    528   λdef.
     367  λdestrs: list register.
     368  λsrcrs1: list register.
     369  λsrcrs2: list register.
     370  λstart_lbl: label.
     371  λdest_lbl: label.
     372  λdef: rtl_internal_function globals.
    529373  match reduce_strong register register srcrs1 srcrs2 with
    530374  [ dp reduced first_reduced_proof ⇒
     
    543387        let destrs_rest ≝ \snd (\fst reduced) in
    544388        let srcrs_cted ≝ \fst (\snd reduced) in
    545         let 〈def, tmpr〉 ≝ fresh_reg def in
     389        let 〈def, tmpr〉 ≝ fresh_reg rtl_params0 globals def in
    546390        let insts_init ≝ [
    547           rtl_st_clear_carry start_lbl;
    548           rtl_st_int tmpr (zero ?) start_lbl
     391          sequential … (CLEAR_CARRY …);
     392          sequential … (INT rtl_params_ globals tmpr (zero …))
    549393        ] in
    550         let f_add ≝ λdestr. λsrcr1. λsrcr2. rtl_st_op2 op destr srcr1 srcr2 start_lbl in
    551         let insts_add ≝ map3 f_add destrs_common srcrsl_common srcrsr_common ? ? in
    552         let f_add_cted ≝ λdestr. λsrcr. rtl_st_op2 op destr srcr tmpr start_lbl in
    553         let insts_add_cted ≝ map2 ? ? ? f_add_cted destrs_cted srcrs_cted ? in
    554         let f_rest ≝ λdestr. rtl_st_op2 op destr tmpr tmpr start_lbl in
     394        let f_add ≝ λdestr. λsrcr1. λsrcr2. sequential … (OP2 rtl_params_ globals op destr srcr1 srcr2) in
     395        let insts_add ≝ map3 ? ? ? ? f_add destrs_common srcrsl_common srcrsr_common ? ? in
     396        let f_add_cted ≝ λdestr. λsrcr. sequential … (OP2 rtl_params_ globals op destr srcr tmpr) in
     397        let insts_add_cted ≝ map2 f_add_cted destrs_cted srcrs_cted ? in
     398        let f_rest ≝ λdestr. sequential … (OP2 rtl_params_ globals op destr tmpr tmpr) in
    555399        let insts_rest ≝ map … f_rest destrs_rest in
    556           adds_graph (insts_init @ insts_add @ insts_add_cted @ insts_rest) start_lbl dest_lbl def
     400          adds_graph rtl_params1 globals (insts_init @ insts_add @ insts_add_cted @ insts_rest) start_lbl dest_lbl def
    557401      ]
    558402    ]
     
    560404  [1: @third_reduced_proof
    561405  |3: @first_reduced_proof
    562   |*: cases daemon (* TODO *)
     406  |*: cases daemon (* XXX: some of these look like they may be false *)
    563407  ]
    564408qed.
    565409
    566410let rec translate_mul1
    567   (dummy: register) (tmpr: register) (destrs: list register)
    568   (srcrs1: list register) (srcr2: register) (start_lbl: label)
    569     on srcrs1 ≝
     411  (globals: list ident) (dummy: register) (tmpr: register)
     412    (destrs: list register) (srcrs1: list register) (srcr2: register)
     413      (start_lbl: label)
     414        on srcrs1 ≝
    570415  match destrs with
    571   [ nil ⇒ adds_graph [ rtl_st_skip start_lbl ] start_lbl
     416  [ nil ⇒ adds_graph rtl_params1 globals [ GOTO … ] start_lbl
    572417  | cons destr tl ⇒
    573418    match tl with
     
    575420      match srcrs1 with
    576421      [ nil ⇒
    577         adds_graph [
    578           rtl_st_int tmpr (zero ?) start_lbl;
    579           rtl_st_op2 Addc destr destr tmpr start_lbl
     422        adds_graph rtl_params1 globals [
     423          sequential … (INT rtl_params_ globals tmpr (zero …));
     424          sequential … (OP2 rtl_params_ globals Addc destr destr tmpr)
    580425        ] start_lbl
    581426      | cons srcr1 tl' ⇒
    582         adds_graph [
    583           rtl_st_opaccs Mul tmpr dummy srcr2 srcr1 start_lbl;
    584           rtl_st_op2 Addc destr destr tmpr start_lbl
     427        adds_graph rtl_params1 globals [
     428          sequential … (OPACCS rtl_params_ globals Mul tmpr dummy srcr2 srcr1);
     429          sequential … (OP2 rtl_params_ globals Addc destr destr tmpr)
    585430        ] start_lbl
    586431      ]
     
    588433      match srcrs1 with
    589434      [ nil ⇒
    590         add_translates [
    591           adds_graph [
    592             rtl_st_int tmpr (zero ?) start_lbl;
    593             rtl_st_op2 Addc destr destr tmpr start_lbl;
    594             rtl_st_op2 Addc destr2 tmpr tmpr start_lbl
     435        add_translates rtl_params1 globals [
     436          adds_graph rtl_params1 globals [
     437            sequential … (INT rtl_params_ globals tmpr (zero …));
     438            sequential … (OP2 rtl_params_ globals Addc destr destr tmpr);
     439            sequential … (OP2 rtl_params_ globals Addc destr2 tmpr tmpr)
    595440          ];
    596           translate_cst (Ointconst I8 (zero ?)) destrs
     441          translate_cst globals (Ointconst I8 (zero …)) destrs
    597442        ] start_lbl
    598443      | cons srcr1 srcrs1 ⇒
    599444        match destrs with
    600445        [ nil ⇒
    601           add_translates [
    602             adds_graph [
    603               rtl_st_int tmpr (zero ?) start_lbl;
    604               rtl_st_op2 Addc destr destr tmpr start_lbl;
    605               rtl_st_op2 Addc destr2 tmpr tmpr start_lbl
     446          add_translates rtl_params1 globals [
     447            adds_graph rtl_params1 globals [
     448              sequential … (INT rtl_params_ globals tmpr (zero …));
     449              sequential … (OP2 rtl_params_ globals Addc destr destr tmpr);
     450              sequential … (OP2 rtl_params_ globals Addc destr2 tmpr tmpr)
    606451            ];
    607             translate_cst (Ointconst I8 (zero ?)) destrs
     452            translate_cst globals (Ointconst I8 (zero ?)) destrs
    608453          ] start_lbl
    609454        | cons destr2 destrs ⇒
    610           add_translates [
    611             adds_graph [
    612               rtl_st_opaccs Mul tmpr destr2 srcr2 srcr1 start_lbl;
    613               rtl_st_op2 Addc destr destr tmpr start_lbl
     455          add_translates rtl_params1 globals [
     456            adds_graph rtl_params1 globals [
     457              sequential … (OPACCS rtl_params_ globals Mul tmpr destr2 srcr2 srcr1);
     458              sequential … (OP2 rtl_params_ globals Addc destr destr tmpr)
    614459            ];
    615             translate_mul1 dummy tmpr (destr2 :: destrs) srcrs1 srcr2
     460            translate_mul1 globals dummy tmpr (destr2 :: destrs) srcrs1 srcr2
    616461          ] start_lbl
    617462        ]
     
    621466
    622467definition translate_muli ≝
     468  λglobals: list ident.
    623469  λdummy: register.
    624470  λtmpr: register.
     
    631477  λtranslates: list ?.
    632478  λsrcr2i: register.
    633   let 〈tmp_destrs1, tmp_destrs2〉 ≝ split ? tmp_destrs i i_prf in
     479  let 〈tmp_destrs1, tmp_destrs2〉 ≝ split tmp_destrs i i_prf in
    634480  let tmp_destrs2' ≝
    635481    match tmp_destrs2 with
    636482    [ nil ⇒ [ ]
    637483    | cons tmp_destr2 tmp_destrs2 ⇒ [
    638         adds_graph [
    639           rtl_st_clear_carry dummy_lbl;
    640           rtl_st_int tmp_destr2 (zero ?) dummy_lbl
     484        adds_graph rtl_params1 globals [
     485          sequential rtl_params_ globals (CLEAR_CARRY …);
     486          sequential … (INT rtl_params_ globals tmp_destr2 (zero …))
    641487        ];
    642         translate_mul1 dummy tmpr tmp_destrs2 srcrs1 srcr2i;
    643         translate_cst (Ointconst I8 (zero ?)) tmp_destrs1;
    644         adds_graph [
    645           rtl_st_clear_carry dummy_lbl
     488        translate_mul1 globals dummy tmpr tmp_destrs2 srcrs1 srcr2i;
     489        translate_cst globals (Ointconst I8 (zero …)) tmp_destrs1;
     490        adds_graph rtl_params1 globals [
     491          sequential rtl_params_ globals (CLEAR_CARRY …)
    646492        ];
    647         translate_op Addc destrs destrs tmp_destrs
     493        translate_op globals Addc destrs destrs tmp_destrs
    648494      ]
    649495    ]
     
    652498
    653499axiom translate_mul:
     500  ∀globals: list ident.
    654501  ∀destrs: list register.
    655502  ∀srcrs1: list register.
     
    657504  ∀start_lbl: label.
    658505  ∀dest_lbl: label.
    659   ∀def: rtl_internal_function.
    660     rtl_internal_function.
     506  ∀def: rtl_internal_function globals.
     507    rtl_internal_function globals.
    661508
    662509(*
    663510definition translate_mul ≝
     511  λglobals: list ident.
    664512  λdestrs: list register.
    665513  λsrcrs1: list register.
     
    667515  λstart_lbl: label.
    668516  λdest_lbl: label.
    669   λdef: rtl_internal_function.
    670   let 〈def, dummy〉 ≝ fresh_reg def in
    671   let 〈def, tmpr〉 ≝ fresh_reg def in
    672   let 〈def, tmp_destrs〉 ≝ fresh_regs def (|destrs|) in
    673   let 〈def, fresh_srcrs1〉 ≝ fresh_regs def (|srcrs1|) in
    674   let 〈def, fresh_srcrs2〉 ≝ fresh_regs def (|srcrs2|) in
     517  λdef: rtl_internal_function globals.
     518  let 〈def, dummy〉 ≝ fresh_reg rtl_params0 globals def in
     519  let 〈def, tmpr〉 ≝ fresh_reg rtl_params0 globals def in
     520  let 〈def, tmp_destrs〉 ≝ fresh_regs rtl_params0 globals def (|destrs|) in
     521  let 〈def, fresh_srcrs1〉 ≝ fresh_regs rtl_params0 globals def (|srcrs1|) in
     522  let 〈def, fresh_srcrs2〉 ≝ fresh_regs rtl_params0 globals def (|srcrs2|) in
    675523  let insts_init ≝ [
    676     translate_move fresh_srcrs1 srcrs1;
    677     translate_move fresh_srcrs2 srcrs2;
    678     translate_cst (Ointconst I8 (zero ?)) destrs
     524    translate_move globals fresh_srcrs1 srcrs1;
     525    translate_move globals fresh_srcrs2 srcrs2;
     526    translate_cst globals (Ointconst I8 (zero …)) destrs
    679527  ]
    680528  in
    681   let f ≝ λi. translate_muli dummy tmpr destrs tmp_destrs ? fresh_srcrs1 start_lbl i ? in
    682   let insts_mul ≝ foldi ? ? [ ] srcrs2 in ?. [5: check insts_init.
     529  let f ≝ λi. translate_muli globals dummy tmpr destrs tmp_destrs ? fresh_srcrs1 start_lbl i ? in
     530  let insts_mul ≝ foldi [ ] srcrs2 in ?. [5: check insts_init.
    683531    add_translates (insts_init @ insts_mul) start_lbl dest_lbl def.
    684532*)
    685533
    686534definition translate_divumodu8 ≝
     535  λglobals: list ident.
    687536  λorder: bool.
    688537  λdestrs: list register.
     
    691540  λstart_lbl: label.
    692541  λdest_lbl: label.
    693   λdef: rtl_internal_function.
     542  λdef: rtl_internal_function globals.
    694543  match destrs with
    695   [ nil ⇒ add_graph start_lbl (rtl_st_skip dest_lbl) def
     544  [ nil ⇒ add_graph rtl_params1 globals start_lbl (GOTO … dest_lbl) def
    696545  | cons destr destrs ⇒
    697     let 〈def, dummy〉 ≝ fresh_reg def in
     546    let 〈def, dummy〉 ≝ fresh_reg rtl_params0 globals def in
    698547    let 〈destr1, destr2〉 ≝ match order with [ true ⇒ 〈destr, dummy〉 | _ ⇒ 〈dummy, destr〉 ] in
    699     let inst_div ≝ adds_graph [
    700       rtl_st_opaccs DivuModu destr1 destr2 srcr1 srcr2 start_lbl
     548    let inst_div ≝ adds_graph rtl_params1 globals [
     549      sequential rtl_params_ globals (OPACCS … DivuModu destr1 destr2 srcr1 srcr2)
    701550    ]
    702551    in
    703     let insts_rest ≝ translate_cst (Ointconst I8 (zero ?)) destrs in
    704       add_translates [ inst_div; insts_rest ] start_lbl dest_lbl def
    705   ].
    706 
    707 definition translate_ne: ? → ? → ? → ? → ? → ? → rtl_internal_function ≝
     552    let insts_rest ≝ translate_cst globals (Ointconst I8 (zero ?)) destrs in
     553      add_translates rtl_params1 globals [ inst_div; insts_rest ] start_lbl dest_lbl def
     554  ].
     555
     556definition translate_ne: ∀globals: list ident. ? → ? → ? → ? → ? → ? → rtl_internal_function globals ≝
     557  λglobals: list ident.
    708558  λdestrs: list register.
    709559  λsrcrs1: list register.
     
    711561  λstart_lbl: label.
    712562  λdest_lbl: label.
    713   λdef: rtl_internal_function.
     563  λdef: rtl_internal_function globals.
    714564  match destrs with
    715   [ nil ⇒ add_graph start_lbl (rtl_st_skip dest_lbl) def
     565  [ nil ⇒ add_graph rtl_params1 globals start_lbl (GOTO … dest_lbl) def
    716566  | cons destr destrs ⇒
    717     let 〈def, tmpr〉 ≝ fresh_reg def in
    718     let 〈def, tmp_zero〉 ≝ fresh_reg def in
    719     let 〈def, tmp_srcrs1〉 ≝ fresh_regs def (|srcrs1|) in
    720     let save_srcrs1 ≝ translate_move tmp_srcrs1 srcrs1 in
    721     let 〈def, tmp_srcrs2〉 ≝ fresh_regs def (|srcrs2|) in
    722     let save_srcrs2 ≝ translate_move tmp_srcrs2 srcrs2 in
     567    let 〈def, tmpr〉 ≝ fresh_reg rtl_params0 globals def in
     568    let 〈def, tmp_zero〉 ≝ fresh_reg rtl_params0 globals def in
     569    let 〈def, tmp_srcrs1〉 ≝ fresh_regs rtl_params0 globals def (|srcrs1|) in
     570    let save_srcrs1 ≝ translate_move globals tmp_srcrs1 srcrs1 in
     571    let 〈def, tmp_srcrs2〉 ≝ fresh_regs rtl_params0 globals def (|srcrs2|) in
     572    let save_srcrs2 ≝ translate_move globals tmp_srcrs2 srcrs2 in
    723573    match reduce_strong register register tmp_srcrs1 tmp_srcrs2 with
    724574    [ dp crl their_proof ⇒
     
    729579      let rest ≝ choose_rest ? restl restr ? ? in
    730580      let inits ≝ [
    731         rtl_st_int destr (zero ?) start_lbl;
    732         rtl_st_int tmp_zero (zero ?) start_lbl
     581        sequential … (INT rtl_params_ globals destr (zero …));
     582        sequential … (INT rtl_params_ globals tmp_zero (zero …))
    733583      ]
    734584      in
    735585      let f_common ≝ λtmp_srcr1. λtmp_srcr2. [
    736         rtl_st_clear_carry start_lbl;
    737         rtl_st_op2 Sub tmpr tmp_srcr1 tmp_srcr2 start_lbl;
    738         rtl_st_op2 Or destr destr tmpr start_lbl
     586        sequential … (CLEAR_CARRY …);
     587        sequential … (OP2 rtl_params_ globals Sub tmpr tmp_srcr1 tmp_srcr2);
     588        sequential … (OP2 rtl_params_ globals Or destr destr tmpr)
    739589      ]
    740590      in
    741       let insts_common ≝ flatten ? (map2 … f_common commonl commonr ?) in
     591      let insts_common ≝ flatten (map2 … f_common commonl commonr ?) in
    742592      let f_rest ≝ λtmp_srcr. [
    743         rtl_st_clear_carry start_lbl;
    744         rtl_st_op2 Sub tmpr tmp_zero tmp_srcr start_lbl;
    745         rtl_st_op2 Or destr destr tmpr start_lbl
     593        sequential … (CLEAR_CARRY …);
     594        sequential … (OP2 rtl_params_ globals Sub tmpr tmp_zero tmp_srcr);
     595        sequential … (OP2 rtl_params_ globals Or destr destr tmpr)
    746596      ]
    747597      in
    748       let insts_rest ≝ flatten ? (map ? ? f_rest rest) in
     598      let insts_rest ≝ flatten … (map … f_rest rest) in
    749599      let insts ≝ inits @ insts_common @ insts_rest in
    750       let epilogue ≝ translate_cst (Ointconst I8 (zero ?)) destrs in
    751         add_translates [
    752           save_srcrs1; save_srcrs2; adds_graph insts; epilogue
     600      let epilogue ≝ translate_cst globals (Ointconst I8 (zero …)) destrs in
     601        add_translates rtl_params1 globals [
     602          save_srcrs1; save_srcrs2; adds_graph rtl_params1 globals insts; epilogue
    753603        ] start_lbl dest_lbl def
    754604    ]
     
    762612
    763613definition translate_eq_reg ≝
     614  λglobals: list ident.
    764615  λtmp_zero: register.
    765616  λtmp_one: register.
     
    770621  λsrcr12: register × register.
    771622  let 〈srcr1, srcr2〉 ≝ srcr12 in
    772   [ rtl_st_clear_carry dummy_lbl;
    773     rtl_st_op2 Sub tmpr1 srcr1 srcr2 dummy_lbl;
    774     rtl_st_op2 Addc tmpr1 tmp_zero tmp_zero dummy_lbl;
    775     rtl_st_op2 Sub tmpr2 srcr2 srcr1 dummy_lbl;
    776     rtl_st_op2 Addc tmpr2 tmp_zero tmp_zero dummy_lbl;
    777     rtl_st_op2 Or tmpr1 tmpr1 tmpr2 dummy_lbl;
    778     rtl_st_op2 Xor tmpr1 tmpr1 tmp_one dummy_lbl;
    779     rtl_st_op2 And destr destr tmpr1 dummy_lbl ].
     623  [ sequential … (CLEAR_CARRY …);
     624    sequential rtl_params_ globals (OP2 rtl_params_ globals Sub tmpr1 srcr1 srcr2);
     625    sequential … (OP2 rtl_params_ globals Addc tmpr1 tmp_zero tmp_zero);
     626    sequential … (OP2 rtl_params_ globals Sub tmpr2 srcr2 srcr1);
     627    sequential … (OP2 rtl_params_ globals Addc tmpr2 tmp_zero tmp_zero);
     628    sequential … (OP2 rtl_params_ globals Or tmpr1 tmpr1 tmpr2);
     629    sequential … (OP2 rtl_params_ globals Xor tmpr1 tmpr1 tmp_one);
     630    sequential … (OP2 rtl_params_ globals And destr destr tmpr1) ].
    780631
    781632definition translate_eq_list ≝
     633  λglobals: list ident.
    782634  λtmp_zero: register.
    783635  λtmp_one: register.
     
    787639  λleq: list (register × register).
    788640  λdummy_lbl: label.
    789   let f ≝ translate_eq_reg tmp_zero tmp_one tmpr1 tmpr2 destr dummy_lbl in
    790     (rtl_st_int destr (bitvector_of_nat ? 1) dummy_lbl) ::
    791       flatten ? (map ? ? f leq).
     641  let f ≝ translate_eq_reg globals tmp_zero tmp_one tmpr1 tmpr2 destr dummy_lbl in
     642    (sequential … (INT rtl_params_ globals destr (bitvector_of_nat ? 1))) ::
     643      flatten … (map … f leq).
    792644
    793645definition translate_atom ≝
     646  λglobals: list ident.
    794647  λtmp_zero: register.
    795648  λtmp_one: register.
     
    802655  λsrcr1: register.
    803656  λsrcr2: register.
    804     translate_eq_list tmp_zero tmp_one tmpr1 tmpr2 tmpr3 leq dummy_lbl @
    805     [ rtl_st_clear_carry dummy_lbl;
    806       rtl_st_op2 Sub tmpr1 srcr1 srcr2 dummy_lbl;
    807       rtl_st_op2 Addc tmpr1 tmp_zero tmp_zero dummy_lbl;
    808       rtl_st_op2 And tmpr3 tmpr3 tmpr1 dummy_lbl;
    809       rtl_st_op2 Or destr destr tmpr3 dummy_lbl ].
     657    translate_eq_list globals tmp_zero tmp_one tmpr1 tmpr2 tmpr3 leq dummy_lbl @
     658    [ sequential … (CLEAR_CARRY …);
     659      sequential … (OP2 rtl_params_ globals Sub tmpr1 srcr1 srcr2);
     660      sequential … (OP2 rtl_params_ globals Addc tmpr1 tmp_zero tmp_zero);
     661      sequential … (OP2 rtl_params_ globals And tmpr3 tmpr3 tmpr1);
     662      sequential … (OP2 rtl_params_ globals Or destr destr tmpr3) ].
    810663
    811664definition translate_lt_main ≝
     665  λglobals: list ident.
    812666  λtmp_zero: register.
    813667  λtmp_one: register.
     
    822676  let f ≝ λinsts_leq. λsrcr1. λsrcr2.
    823677    let 〈insts, leq〉 ≝ insts_leq in
    824     let added_insts ≝ translate_atom tmp_zero tmp_one tmpr1 tmpr2 tmpr3 destr dummy_lbl leq srcr1 srcr2 in
     678    let added_insts ≝ translate_atom globals tmp_zero tmp_one tmpr1 tmpr2 tmpr3 destr dummy_lbl leq srcr1 srcr2 in
    825679      〈insts @ added_insts, leq @ [〈srcr1, srcr2〉]〉
    826680  in
    827     \fst (fold_left2 ? ? ? f 〈[ ], [ ]〉 srcrs1 srcrs2 proof).
     681    \fst (fold_left2 f 〈[ ], [ ]〉 srcrs1 srcrs2 proof).
    828682
    829683definition fresh_regs_strong:
    830   rtl_internal_function → ∀n: nat. Σfresh: rtl_internal_function × (list register). |\snd fresh| = n ≝
     684  ∀globals. rtl_internal_function globals → ∀n: nat. Σfresh: (rtl_internal_function globals) × (list register). |\snd fresh| = n ≝
     685  λglobals: list ident.
    831686  λdef.
    832687  λn.
    833     fresh_regs def n.
     688    fresh_regs rtl_params0 globals def n.
    834689  @fresh_regs_length
    835690qed.
    836691
    837692definition complete_regs_strong:
    838   rtl_internal_function → list register → list register → Σcomplete: (list register) × (list register) × (list register). |\fst (\fst complete)| = |\snd (\fst complete)| ≝
     693  ∀globals: list ident. rtl_internal_function globals → list register → list register → Σcomplete: (list register) × (list register) × (list register). |\fst (\fst complete)| = |\snd (\fst complete)| ≝
     694  λglobals: list ident.
    839695  λdef.
    840696  λleft.
    841697  λright.
    842     complete_regs def left right.
     698    complete_regs globals def left right.
    843699  @complete_regs_length
    844700qed.
    845701
    846702definition translate_lt ≝
     703  λglobals: list ident.
    847704  λdestrs: list register.
    848705  λprf_destrs: lt 0 (|destrs|).
     
    851708  λstart_lbl: label.
    852709  λdest_lbl: label.
    853   λdef: rtl_internal_function.
     710  λdef: rtl_internal_function globals.
    854711  match destrs with
    855   [ nil ⇒ add_graph start_lbl (rtl_st_skip dest_lbl) def
     712  [ nil ⇒ add_graph rtl_params1 globals start_lbl (GOTO … dest_lbl) def
    856713  | _ ⇒
    857     match fresh_regs_strong def (|destrs|) with
     714    match fresh_regs_strong globals def (|destrs|) with
    858715    [ dp def_tmp_destrs tmp_destrs_proof ⇒
    859716      let def ≝ \fst def_tmp_destrs in
    860717      let tmp_destrs ≝ \snd def_tmp_destrs in
    861718      let tmp_destr ≝ hd_safe ? tmp_destrs ? in
    862       let 〈def, tmp_zero〉 ≝ fresh_reg def in
    863       let 〈def, tmp_one〉 ≝ fresh_reg def in
    864       let 〈def, tmpr1〉 ≝ fresh_reg def in
    865       let 〈def, tmpr2〉 ≝ fresh_reg def in
    866       let 〈def, tmpr3〉 ≝ fresh_reg def in
    867       match complete_regs_strong def srcrs1 srcrs2 with
     719      let 〈def, tmp_zero〉 ≝ fresh_reg rtl_params1 globals def in
     720      let 〈def, tmp_one〉 ≝ fresh_reg rtl_params1 globals def in
     721      let 〈def, tmpr1〉 ≝ fresh_reg rtl_params1 globals def in
     722      let 〈def, tmpr2〉 ≝ fresh_reg rtl_params1 globals def in
     723      let 〈def, tmpr3〉 ≝ fresh_reg rtl_params1 globals def in
     724      match complete_regs_strong globals def srcrs1 srcrs2 with
    868725      [ dp srcrs12_added srcrs12_proof ⇒
    869726        let srcrs1 ≝ \fst (\fst srcrs12_added) in
    870727        let srcrs2 ≝ \snd (\fst srcrs12_added) in
    871728        let added ≝ \snd srcrs12_added in
    872         let srcrs1' ≝ rev ? srcrs1 in
    873         let srcrs2' ≝ rev ? srcrs2 in
     729        let srcrs1' ≝ rev srcrs1 in
     730        let srcrs2' ≝ rev srcrs2 in
    874731        let insts_init ≝ [
    875           translate_cst (Ointconst I8 (zero ?)) tmp_destrs;
    876           translate_cst (Ointconst I8 (zero ?)) added;
    877           adds_graph [
    878             rtl_st_int tmp_zero (zero ?) start_lbl;
    879             rtl_st_int tmp_one (bitvector_of_nat ? 1) start_lbl
     732          translate_cst globals (Ointconst I8 (zero ?)) tmp_destrs;
     733          translate_cst globals (Ointconst I8 (zero ?)) added;
     734          adds_graph rtl_params1 globals [
     735            sequential rtl_params_ globals (INT rtl_params_ globals tmp_zero (zero …));
     736            sequential rtl_params_ globals (INT rtl_params_ globals tmp_one (bitvector_of_nat … 1))
    880737          ]
    881738        ]
    882739        in
    883740        let insts_main ≝
    884           translate_lt_main tmp_zero tmp_one tmpr1 tmpr2 tmpr3 tmp_destr start_lbl srcrs1' srcrs2' ? in
    885           let insts_main ≝ [ adds_graph insts_main ] in
    886           let insts_exit ≝ [ translate_move destrs tmp_destrs ] in
    887             add_translates (insts_init @ insts_main @ insts_exit) start_lbl dest_lbl def
     741          translate_lt_main globals tmp_zero tmp_one tmpr1 tmpr2 tmpr3 tmp_destr start_lbl srcrs1' srcrs2' ? in
     742          let insts_main ≝ [ adds_graph rtl_params1 globals insts_main ] in
     743          let insts_exit ≝ [ translate_move globals destrs tmp_destrs ] in
     744            add_translates rtl_params1 globals (insts_init @ insts_main @ insts_exit) start_lbl dest_lbl def
    888745      ]
    889746    ]
     
    897754
    898755definition add_128_to_last ≝
     756  λglobals: list ident.
    899757  λtmp_128: register.
    900758  λrs.
     
    902760  λstart_lbl: label.
    903761  match rs with
    904   [ nil ⇒ adds_graph [ ] start_lbl
     762  [ nil ⇒ adds_graph rtl_params1 globals [ ] start_lbl
    905763  | _ ⇒
    906     let r ≝ last_safe ? rs prf in
    907       adds_graph [
    908         rtl_st_op2 Add r r tmp_128 start_lbl
     764    let r ≝ last_safe rs prf in
     765      adds_graph rtl_params1 globals [
     766        sequential rtl_params_ globals (OP2 rtl_params_ globals Add r r tmp_128)
    909767      ] start_lbl
    910768  ].
    911769
    912770definition translate_lts ≝
     771  λglobals: list ident.
    913772  λdestrs: list register.
    914773  λdestrs_prf: lt 0 (|destrs|).
     
    919778  λstart_lbl: label.
    920779  λdest_lbl: label.
    921   λdef: rtl_internal_function.
    922   match fresh_regs_strong def (|srcrs1|) with
     780  λdef: rtl_internal_function globals.
     781  match fresh_regs_strong globals def (|srcrs1|) with
    923782  [ dp def_tmp_srcrs1 srcrs1_prf ⇒
    924783    let def ≝ \fst def_tmp_srcrs1 in
    925784    let tmp_srcrs1 ≝ \snd def_tmp_srcrs1 in
    926     match fresh_regs_strong def (|srcrs2|) with
     785    match fresh_regs_strong globals def (|srcrs2|) with
    927786    [ dp def_tmp_srcrs2 srcrs2_prf ⇒
    928787      let def ≝ \fst def_tmp_srcrs2 in
    929788      let tmp_srcrs2 ≝ \snd def_tmp_srcrs2 in
    930       let 〈def, tmp_128〉 ≝ fresh_reg def in
    931         add_translates [
    932           translate_move tmp_srcrs1 srcrs1;
    933           translate_move tmp_srcrs2 srcrs2;
    934           adds_graph [
    935             rtl_st_int tmp_128 (bitvector_of_nat ? 128) start_lbl
     789      let 〈def, tmp_128〉 ≝ fresh_reg rtl_params0 globals def in
     790        add_translates rtl_params1 globals [
     791          translate_move globals tmp_srcrs1 srcrs1;
     792          translate_move globals tmp_srcrs2 srcrs2;
     793          adds_graph rtl_params1 globals [
     794            sequential rtl_params_ globals (INT rtl_params_ globals tmp_128 (bitvector_of_nat ? 128))
    936795          ];
    937           add_128_to_last tmp_128 tmp_srcrs1 ?;
    938           add_128_to_last tmp_128 tmp_srcrs2 ?;
    939           translate_lt destrs destrs_prf tmp_srcrs1 tmp_srcrs2
     796          add_128_to_last globals tmp_128 tmp_srcrs1 ?;
     797          add_128_to_last globals tmp_128 tmp_srcrs2 ?;
     798          translate_lt globals destrs destrs_prf tmp_srcrs1 tmp_srcrs2
    940799        ] start_lbl dest_lbl def
    941800    ]
     
    947806
    948807definition translate_op2 ≝
     808  λglobals: list ident.
    949809  λop2.
    950810  λdestrs: list register.