Changeset 2286


Ignore:
Timestamp:
Aug 2, 2012, 3:18:11 PM (7 years ago)
Author:
tranquil
Message:

Big update!

  • merge of all _paolo variants
  • reorganised some depends (in particular, Register and thus back-end laguages no longer have fake ASM dependency)
  • split I8051.ma spawning new BackEndOps?.ma

compiler.ma broken at the moment, but not by these changes as far as I can tell

Location:
src
Files:
1 added
22 deleted
35 edited

Legend:

Unmodified
Added
Removed
  • src/ASM/I8051.ma

    r2275 r2286  
    33
    44include "ASM/String.ma".
    5 include "ASM/ASM.ma".
     5(*include "ASM/ASM.ma".*)
    66include "ASM/Arithmetic.ma". 
    77
     
    99definition ptr_size ≝ bitvector_of_nat 8 2.
    1010definition alignment ≝ None.
    11 
    12 (* dpm: Can these two inductive definitions be merged? In LIN, yes, but perhaps
    13         not further back in the translation chain.                            *)
    14 inductive OpAccs: Type[0] ≝
    15   Mul: OpAccs
    16 | DivuModu: OpAccs.
    17 
    18 inductive Op1: Type[0] ≝
    19   Cmpl: Op1
    20 | Inc: Op1
    21 | Rl: Op1. (* TODO: implement left rotation *)
    22 
    23 inductive Op2: Type[0] ≝
    24   Add: Op2
    25 | Addc: Op2
    26 | Sub: Op2
    27 | And: Op2
    28 | Or: Op2
    29 | Xor: Op2.
    3011
    3112(* dpm: maybe useless? *)
     
    170151   Register31; Register32; Register33; Register34; Register35;
    171152   Register36; Register37].
    172 
    173 definition register_address: Register → [[ acc_a; direct; registr ]] ≝
    174   λr: Register.
    175     match r with
    176     [ Register00 ⇒ REGISTER [[ false; false; false ]]
    177     | Register01 ⇒ REGISTER [[ false; false; true ]]
    178     | Register02 ⇒ REGISTER [[ false; true; false ]]
    179     | Register03 ⇒ REGISTER [[ false; true; true ]]
    180     | Register04 ⇒ REGISTER [[ true; false; false ]]
    181     | Register05 ⇒ REGISTER [[ true; false; true ]]
    182     | Register06 ⇒ REGISTER [[ true; true; false ]]
    183     | Register07 ⇒ REGISTER [[ true; true; true ]]
    184     | RegisterA ⇒ ACC_A
    185     | RegisterB ⇒ DIRECT (bitvector_of_nat 8 240)
    186     | RegisterDPL ⇒ DIRECT (bitvector_of_nat 8 82)
    187     | RegisterDPH ⇒ DIRECT (bitvector_of_nat 8 83)
    188     | _ ⇒ DIRECT (bitvector_of_nat 8 (nat_of_register r))
    189     ].
    190     [*: normalize
    191         @ I
    192     ]
    193 qed.
    194 
    195 record Eval: Type[0] ≝
    196 {
    197   opaccs: OpAccs → Byte → Byte → Byte × Byte;
    198   op1: Op1 → Byte → Byte;
    199   op2: Bit → Op2 → Byte → Byte → (Byte × Bit)
    200 }.
    201 
    202 axiom opaccs_implementation: OpAccs → Byte → Byte → Byte × Byte.
    203 axiom op1_implementation: Op1 → Byte → Byte.
    204 axiom op2_implementation: Bit → Op2 → Byte → Byte → (Byte × Bit).
    205 
    206 definition eval: Eval ≝
    207   mk_Eval opaccs_implementation
    208           op1_implementation
    209           op2_implementation.
  • src/ASM/Util.ma

    r2211 r2286  
    14371437interpretation "dependent if then else" 'if_then_else_safe b f g = (if_then_else_safe ? b f g).
    14381438
     1439lemma If_elim : ∀A.∀P : A → Prop.∀b : bool.∀f : b → A.∀g : Not (bool_to_Prop b) → A.
     1440  (∀prf.P (f prf)) → (∀prf.P (g prf)) → P (If b then with prf do f prf else with prf do g prf).
     1441#A #P * #f #g #H1 #H2 normalize // qed.
     1442
    14391443(* Also extracts an equality proof (useful when not using Russell). *)
    14401444notation > "hvbox('let' 〈ident x,ident y〉 'as' ident E 'return' ty ≝ t 'in' s)"
  • src/ASM/Vector.ma

    r2124 r2286  
    9292  @(dependent_rewrite_vectors A … E)
    9393  try assumption %
     94qed.
     95
     96lemma Vector_singl_elim : ∀A.∀P : Vector A 1 → Prop.∀v.
     97  (∀a.v = [[ a ]] → P [[ a ]]) → P v.
     98#A #P #v
     99elim (Vector_Sn … v) #a * #tl >(Vector_O … tl) #EQ >EQ #H @H % qed.
     100
     101lemma Vector_pair_elim : ∀A.∀P : Vector A 2 → Prop.∀v.
     102  (∀a,b.v = [[ a ; b ]] → P [[ a ; b ]]) → P v.
     103#A #P #v
     104elim (Vector_Sn … v) #a * #tl @(Vector_singl_elim … tl) #b #EQ1 #EQ2 destruct
     105#H @H %
     106qed.
     107
     108lemma Vector_triple_elim : ∀A.∀P : Vector A 3 → Prop.∀v.
     109  (∀a,b,c.v = [[ a ; b ; c ]] → P [[ a ; b ; c ]]) → P v.
     110#A #P #v
     111elim (Vector_Sn … v) #a * #tl @(Vector_pair_elim … tl) #b #c #EQ1 #EQ2 destruct
     112#H @H %
    94113qed.
    95114
     
    214233[ VEmpty ⇒ I | VCons m hd tl ⇒ tl ].
    215234
     235lemma tail_head' : ∀A,n,v.v = head' A n v ::: tail … v.
     236#A #n #v elim (Vector_Sn … v) #hd * #tl #EQ >EQ % qed.
     237
    216238let rec vsplit' (A: Type[0]) (m, n: nat) on m: Vector A (plus m n) → (Vector A m) × (Vector A n) ≝
    217239 match m return λm. Vector A (plus m n) → (Vector A m) × (Vector A n) with
     
    421443qed.
    422444
     445lemma vector_append_empty : ∀A,n.∀v : Vector A n.v @@ [[ ]] ≃ v.
     446#A #n #v elim v -n [%]
     447#n #hd #tl change with (?→?:::(?@@?)≃?)
     448lapply (tl@@[[ ]])
     449<plus_n_O #v #EQ >EQ %
     450qed.
     451
    423452lemma vector_associative_append:
    424453  ∀A: Type[0].
     
    591620    //
    592621qed.
    593    
     622
     623lemma v_invert_append : ∀A,n,m.∀v,v' : Vector A n.∀u,u' : Vector A m.
     624  v @@ u = v' @@ u' → v = v' ∧ u = u'.
     625#A #n #m #v elim v -n
     626[ #v' >(Vector_O ? v') #u #u' normalize #EQ %{EQ} %
     627| #n #hd #tl #IH #v' elim (Vector_Sn ?? v') #hd' * #tl' #EQv' >EQv' -v'
     628  #u #u' normalize #EQ destruct(EQ) elim (IH … e0) #EQ' #EQ'' %{EQ''}
     629  >EQ' %
     630]
     631qed.
     632
    594633(* -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= *)
    595634(* Other manipulations.                                                       *)
     
    761800  #NE normalize lapply (f_true h h') cases (f h h') // #E @IH >E in NE; /2/
    762801] qed.
     802
     803lemma eq_v_append : ∀A,n,m,test,v1,v2,u1,u2.
     804  eq_v A (n+m) test (v1@@u1) (v2@@u2) =
     805  (eq_v A n test v1 v2 ∧ eq_v A m test u1 u2).
     806#A #n #m #test #v1 lapply m -m elim v1 -n
     807[ #m #v2 >(Vector_O … v2) #u1 #u2 % ]
     808#n #hd #tl #IH #m #v2
     809elim (Vector_Sn … v2) #hd' * #tl' #EQ >EQ -v2
     810#u1 #u2 whd in ⊢ (??%(?%?));
     811whd in match (head' ???);
     812whd in match (tail ???);
     813whd in match (tail ???);
     814elim (test ??) normalize nodelta [ @IH | % ]
     815qed.
    763816
    764817(* -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= *)
     
    881934  ]
    882935qed.
     936
     937(* -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= *)
     938(* Vector prefix and suffix relations.                                        *)
     939(* -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= *)   
     940
     941(* n.b.: if n = m this is equivalent to equality, without n and m needing to be
     942   Leibniz-equal *)
     943let rec vprefix A n m (test : A → A → bool) (v1 : Vector A n) (v2 : Vector A m) on v1 : bool ≝
     944match v1 with
     945[ VEmpty ⇒ true
     946| VCons n' hd1 tl1 ⇒
     947  match v2 with
     948  [ VEmpty ⇒ false
     949  | VCons m' hd2 tl2 ⇒ test hd1 hd2 ∧ vprefix … test tl1 tl2
     950  ]
     951].
     952
     953let rec vsuffix A n m test (v1 : Vector A n) (v2 : Vector A m) on v2 : bool ≝
     954If leb (S n) m then with prf do
     955  match v2 return λm.λv2:Vector A m.leb (S n) m → bool with
     956  [ VEmpty ⇒ Ⓧ
     957  | VCons m' hd2 tl2 ⇒ λ_.vsuffix ?? m' test v1 tl2
     958  ] prf
     959else (if eqb n m then
     960  vprefix A n m test v1 v2
     961else
     962  false).
     963
     964include alias "arithmetics/nat.ma".
     965
     966lemma prefix_to_le : ∀A,n,m,test,v1,v2.
     967  vprefix A n m test v1 v2 → n ≤ m.
     968#A #n #m #test #v1 lapply m -m elim v1 -n [//]
     969#n #hd #tl #IH #m * -m [*]
     970#m #hd' #tl'
     971whd in ⊢ (?%→?);
     972elim (test ??) [2: *]
     973whd in ⊢ (?%→?);
     974#H @le_S_S @(IH … H)
     975qed.
     976
     977lemma vprefix_ok : ∀A,n,m,test,v1,v2.
     978  vprefix A n m test v1 v2 → le n m ∧
     979  ∃pre.∃post : Vector A (m - n).v2 ≃ pre @@ post ∧
     980            bool_to_Prop (eq_v … test v1 pre).
     981#A #n #m #test #v1 #v2 #G %{(prefix_to_le … G)}
     982lapply G lapply v2 lapply m -m elim v1 -n
     983[ #m #v2 * <minus_n_O %{[[ ]]} %{v2} % % ]
     984#n #hd1 #tl1 #IH #m * -m [*]
     985#m #hd2 #tl2 whd in ⊢ (?%→?);
     986elim (true_or_false_Prop (test hd1 hd2)) #H >H normalize nodelta [2: *]
     987#G elim (IH … G) #pre * #post * #EQ #EQ'
     988%{(hd2:::pre)} %{post} %
     989[ change with (?≃hd2 ::: (? @@ ?)) lapply EQ lapply (pre @@ post)
     990  <(minus_to_plus m … (prefix_to_le … G) (refl …))
     991  #V #EQ'' >EQ'' %
     992| whd in ⊢ (?%);
     993  whd in match (head' ???); >H
     994  @EQ'
     995]
     996qed.
     997
     998lemma vprefix_to_eq : ∀A,n,test,v1,v2.
     999  vprefix A n n test v1 v2 = eq_v … test v1 v2.
     1000#A #n #test #v1 elim v1 -n
     1001[ #v2 >(Vector_O … v2) %
     1002| #n #hd1 #tl1 #IH
     1003  #v2 elim (Vector_Sn … v2) #hd2 * #tl2 #EQ destruct(EQ)
     1004  normalize elim (test ??) [2: %]
     1005  normalize @IH
     1006]
     1007qed.
     1008
     1009lemma vprefix_true : ∀A,n,m,test.∀v1,pre : Vector A n.∀post : Vector A m.
     1010  eq_v … test v1 pre → bool_to_Prop (vprefix … test v1 (pre @@ post)).
     1011#A #n #m #test #v1 lapply m -m elim v1 -n
     1012[ #m #pre #post #_ %
     1013| #n #hd #tl #IH #m #pre elim (Vector_Sn … pre) #hd' * #tl' #EQpre >EQpre
     1014  #post
     1015  whd in ⊢ (?%→?%); whd in match (head' ???);
     1016  elim (test hd hd') [2: *] normalize nodelta whd in match (tail ???);
     1017  @IH
     1018]
     1019qed.
     1020
     1021lemma vsuffix_to_le : ∀A,n,m,test,v1,v2.
     1022  vsuffix A n m test v1 v2 → n ≤ m.
     1023#A #n #m #test #v1 #v2 lapply v1 lapply n -n elim v2 -m
     1024[ #n * -n
     1025  [ * %
     1026  | #n #hd #tl *
     1027  ]
     1028| #m #hd2 #tl2 #IH
     1029  #n #v1 change with (bool_to_Prop (If ? then with prf do ? else ?) → ?)
     1030  @If_elim normalize nodelta @leb_elim #H *
     1031  [ #_ @(transitive_le … H) %2 %1
     1032  | #ABS elim (ABS I)
     1033  | #_ @eqb_elim #G normalize nodelta [2: *]
     1034    destruct #_ %
     1035  ]
     1036]
     1037qed.
     1038 
     1039lemma vsuffix_ok : ∀A,n,m,test,v1,v2.
     1040  vsuffix A n m test v1 v2 → le n m ∧
     1041  ∃pre : Vector A (m - n).∃post.v2 ≃ pre @@ post ∧
     1042            bool_to_Prop (eq_v … test v1 post).
     1043#A #n #m #test #v1 #v2 #G %{(vsuffix_to_le … G)}
     1044lapply G lapply v1 lapply n -n
     1045elim v2 -m
     1046[ #n #v1
     1047  whd in ⊢ (?%→?);
     1048  @eqb_elim #EQ1 [2: *]
     1049  normalize nodelta lapply v1 -v1 >EQ1 #v1
     1050  >(Vector_O … v1) * %{[[ ]]} %{[[ ]]} % %
     1051| #m #hd2 #tl2 #IH #n #v1
     1052  change with (bool_to_Prop (If ? then with prf do ? else ?) → ?)
     1053  @If_elim normalize nodelta #H
     1054  [ #G elim (IH … G) #pre * #post * #EQ1 #EQ2
     1055    >minus_Sn_m
     1056    [ %{(hd2:::pre)} %{post} %{EQ2}
     1057      change with (?≃?:::(?@@?))
     1058      lapply EQ1 lapply (pre@@post)
     1059      <plus_minus_m_m
     1060      [ #v #EQ >EQ %]
     1061    ]
     1062    @(vsuffix_to_le … G)
     1063  | @eqb_elim #EQn [2: *] normalize nodelta
     1064    generalize in match (hd2:::tl2);
     1065    <EQn in ⊢ (%→%→??(λ_.??(λ_.?(?%%??)?)));
     1066    #v2' >vprefix_to_eq #G
     1067    <EQn in ⊢ (?%(λ_:%.??(λ_.?(???%%)?)));
     1068    <minus_n_n %{[[ ]]} %{v2'} %{G}
     1069    %
     1070  ]
     1071]
     1072qed.
     1073
     1074lemma vsuffix_true : ∀A,n,m,test.∀pre : Vector A n.∀v1,post : Vector A m.
     1075  eq_v … test v1 post → bool_to_Prop (vsuffix … test v1 (pre @@ post)).
     1076#A #n #m #test #pre lapply m -m elim pre -n
     1077[ #m #v1 #post lapply v1 -v1 cases post -m
     1078  [ #v1 >(Vector_O … v1) * %
     1079  | #m #hd #tl #v1 #G
     1080    change with (bool_to_Prop (If ? then with prf do ? else ?))
     1081    @If_elim normalize nodelta
     1082    [ @leb_elim #H * @⊥ @(absurd ? H ?) normalize // ]
     1083    #_ >eqb_n_n normalize nodelta
     1084    >vprefix_to_eq assumption
     1085  ]
     1086| #n #hd2 #tl2 #IH
     1087  #m #v1 #post #G
     1088  change with (bool_to_Prop (If ? then with prf do ? else ?))
     1089  @If_elim normalize nodelta
     1090  [ #H @IH @G
     1091  | @leb_elim [ #_ * #ABS elim (ABS I) ]
     1092    #H #_ @eqb_elim #K
     1093    [ @⊥ @(absurd ? K) @lt_to_not_eq // ]
     1094    normalize elim H -H #H @H normalize
     1095    >plus_n_Sm_fast //
     1096  ]
     1097]
     1098qed.
     1099
     1100(* -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= *)
     1101(* Vector flattening and recursive splitting.                                 *)
     1102(* -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= *)   
     1103
     1104let rec rvsplit A n m on n : Vector A (n * m) → Vector (Vector A m) n ≝
     1105match n return λn.Vector ? (n * m) → Vector (Vector ? m) n with
     1106[ O ⇒ λ_.VEmpty ?
     1107| S k ⇒
     1108  λv.let 〈pre,post〉 ≝ vsplit … m (k*m) v in
     1109  pre ::: rvsplit … post
     1110].
     1111
     1112let rec vflatten A n m (v : Vector (Vector A m) n) on v : Vector A (n * m) ≝
     1113match v return λn.λ_ : Vector ? n.Vector ? (n * m) with
     1114[ VEmpty ⇒ VEmpty ?
     1115| VCons n' hd tl ⇒ hd @@ vflatten ? n' m tl
     1116].
     1117
     1118lemma vflatten_rvsplit : ∀A,n,m,v.vflatten A n m (rvsplit A n m v) = v.
     1119#A #n elim n -n
     1120[ #m #v >(Vector_O ? v) %
     1121| #n #IH #m #v
     1122  whd in match (rvsplit ????);
     1123  @vsplit_elim #pre #post #EQ
     1124  normalize nodelta
     1125  whd in match (vflatten ????); >IH >EQ %
     1126]
     1127qed.
     1128
     1129lemma rvsplit_vflatten : ∀A,n,m,v.rvsplit A n m (vflatten A n m v) = v.
     1130#A #n #m #v elim v -n
     1131[ %
     1132| #n #hd #tl #IH
     1133  whd in match (vflatten ????);
     1134  whd in match (rvsplit ????);
     1135  @vsplit_elim #pre #post #EQ
     1136  elim (v_invert_append … EQ) #EQ1 #EQ2 <EQ1 <EQ2
     1137  normalize nodelta >IH %
     1138]
     1139qed.
     1140
     1141(* Paolo: should'nt it be in the standard library? *)
     1142lemma sym_jmeq : ∀A,B.∀a : A.∀b : B.a≃b → b≃a.
     1143#A #B #a #b * % qed.
     1144
     1145lemma vflatten_append : ∀A,n,m,p,v1,v2.
     1146  vflatten A (n+m) p (v1 @@ v2) ≃ vflatten A n p v1 @@ vflatten A m p v2.
     1147#A #n #m #p #v1 lapply m -m elim v1
     1148[ #m #v2 %
     1149| #n #hd1 #tl1 #IH #m #v2
     1150  whd in ⊢ (??%?(????%?));
     1151  lapply (IH … v2)
     1152  lapply (vflatten … (tl1@@v2))
     1153  cut ((n+m)*p = n*p + m*p)
     1154  [ // ] #EQ whd in match (S n + m); whd in match (S ? * ?);
     1155  whd in match (S n * ?); >EQ in ⊢ (%→?%%??→?%%??); -EQ
     1156  #V #EQ >EQ -V @sym_jmeq @vector_associative_append
     1157]
     1158qed.
     1159
     1160lemma eq_v_vflatten : ∀A,n,m,test,v1,v2.
     1161  eq_v A ? test (vflatten A n m v1) (vflatten A n m v2) =
     1162  eq_v ?? (eq_v … test) v1 v2.
     1163#A #n #m #test #v1 elim v1 -n
     1164[ #v2 >(Vector_O … v2) % ]
     1165#n #hd #tl #IH #v2
     1166elim (Vector_Sn … v2) #hd' * #tl' #EQ >EQ -v2
     1167whd in ⊢ (??(????%%)%);
     1168whd in match (head' ???);
     1169whd in match (tail ???);
     1170>eq_v_append >IH %
     1171qed.
     1172
     1173lemma vprefix_vflatten : ∀A,n,m,p,test.∀v1,v2.
     1174  vprefix ? n m (eq_v ? p test) v1 v2 →
     1175  bool_to_Prop (vprefix A (n*p) (m*p) test (vflatten … v1) (vflatten … v2)).
     1176#A #n #m #p #test #v1 #v2 #G
     1177elim (vprefix_ok … G) #le_nm
     1178* #pre * #post *
     1179lapply (vflatten_append … pre post)
     1180lapply (pre @@ post)
     1181<(minus_to_plus … le_nm (refl …)) in ⊢ (%→?%%??→???%%→?);
     1182#v2' #EQ1 #EQ2 >EQ2 -v2 lapply EQ1 -EQ1
     1183lapply (vflatten A m p v2')
     1184cut (m*p = n*p + (m-n)*p)
     1185[ <(commutative_times p) <(commutative_times p) <(commutative_times p)
     1186  <distributive_times_plus <(minus_to_plus … le_nm (refl …)) % ]
     1187#EQ >EQ #v2' #EQ' >EQ' -v2' -v2'
     1188#G @vprefix_true
     1189>eq_v_vflatten @G
     1190qed.
     1191
     1192lemma vsuffix_vflatten : ∀A,n,m,p,test.∀v1,v2.
     1193  vsuffix ? n m (eq_v ? p test) v1 v2 →
     1194  bool_to_Prop (vsuffix A (n*p) (m*p) test (vflatten … v1) (vflatten … v2)).
     1195#A #n #m #p #test #v1 #v2 #G
     1196elim (vsuffix_ok … G) #le_nm * #pre * #post *
     1197lapply (vflatten_append … pre post)
     1198lapply (pre @@ post)
     1199>commutative_plus in ⊢ (%→?%%??→???%%→?);
     1200<(minus_to_plus … le_nm (refl …)) in ⊢ (%→?%%??→???%%→?);
     1201#v2' #EQ1 #EQ2 >EQ2 -v2 lapply EQ1 -EQ1
     1202lapply (vflatten A m p v2')
     1203cut (m*p = (m-n)*p + n*p)
     1204[ <(commutative_times p) <(commutative_times p) <(commutative_times p)
     1205  <distributive_times_plus <commutative_plus <(minus_to_plus … le_nm (refl …)) % ]
     1206#EQ >EQ #v2' #EQ' >EQ'
     1207#G @vsuffix_true
     1208>eq_v_vflatten @G
     1209qed.
  • src/ERTL/ERTL.ma

    r1388 r2286  
    11include "joint/Joint.ma".
    22
    3 inductive move_registers: Type[0] ≝
    4   | pseudo: register → move_registers
    5   | hardware: Register → move_registers.
    6                  
    7 inductive ertl_statement_extension: Type[0] ≝
    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.
     3inductive move_dst: Type[0] ≝
     4  | PSD: register → move_dst
     5  | HDW: Register → move_dst.
    116
    12 definition ertl_params__: params__ ≝
    13  mk_params__ register register register register (move_registers × move_registers)
    14   register nat unit ertl_statement_extension.
    15 definition ertl_params_: params_ ≝ graph_params_ ertl_params__.
    16 definition ertl_params0: params0 ≝ mk_params0 ertl_params__ (list register) nat.
    17 definition ertl_params1: params1 ≝ rtl_ertl_params1 ertl_params0.
    18 definition ertl_params: ∀globals. params globals ≝ rtl_ertl_params ertl_params0.
     7definition move_src ≝ argument move_dst.
    198
    20 definition ertl_statement ≝ joint_statement ertl_params_.
     9definition move_src_from_dst : move_dst → move_src ≝ Reg move_dst.
     10coercion move_dst_to_src : ∀r : move_dst.move_src ≝ move_src_from_dst on _r : move_dst to move_src.
    2111
    22 definition ertl_internal_function ≝
    23   λglobals.joint_internal_function … (ertl_params globals).
     12definition psd_argument_move_src : psd_argument → move_src ≝
     13  λarg.match arg with
     14  [ Imm b ⇒ Imm ? b
     15  | Reg r ⇒ Reg ? (PSD r)
     16  ].
     17coercion psd_argument_to_move_src : ∀a:psd_argument.move_src ≝
     18  psd_argument_move_src on _a : psd_argument to move_src.
    2419
    25 definition ertl_program ≝ joint_program ertl_params.
     20inductive ertl_seq : Type[0] ≝
     21  | ertl_new_frame: ertl_seq
     22  | ertl_del_frame: ertl_seq
     23  | ertl_frame_size: register → ertl_seq.
     24
     25definition ERTL_uns ≝ mk_unserialized_params
     26    (* acc_a_reg ≝ *) register
     27    (* acc_b_reg ≝ *) register
     28    (* acc_a_arg ≝ *) psd_argument
     29    (* acc_b_arg ≝ *) psd_argument
     30    (* dpl_reg   ≝ *) register
     31    (* dph_reg   ≝ *) register
     32    (* dpl_arg   ≝ *) psd_argument
     33    (* dph_arg   ≝ *) psd_argument
     34    (* snd_arg   ≝ *) psd_argument
     35    (* pair_move ≝ *) (move_dst × move_src)
     36    (* call_args ≝ *) ℕ
     37    (* call_dest ≝ *) unit
     38    (* ext_seq ≝ *) ertl_seq
     39    (* ext_call ≝ *) void
     40    (* ext_tailcall ≝ *) void
     41    (* paramsT ≝ *) ℕ
     42    (* localsT ≝ *) register.
     43
     44definition ERTL ≝ mk_graph_params ERTL_uns.
     45definition ertl_program ≝ joint_program ERTL.
     46
     47interpretation "move" 'mov r a = (MOVE ?? (mk_Prod move_dst move_src r a)).
     48
     49(* aid unification *)
     50unification hint 0 ≔
     51(*---------------*) ⊢
     52pair_move ERTL ≡ move_dst × move_src.
     53unification hint 0 ≔
     54(*---------------*) ⊢
     55acc_a_reg ERTL ≡ register.
     56unification hint 0 ≔
     57(*---------------*) ⊢
     58acc_b_reg ERTL ≡ register.
     59unification hint 0 ≔
     60(*---------------*) ⊢
     61acc_a_arg ERTL ≡ psd_argument.
     62unification hint 0 ≔
     63(*---------------*) ⊢
     64acc_b_arg ERTL ≡ psd_argument.
     65unification hint 0 ≔
     66(*---------------*) ⊢
     67dpl_reg ERTL ≡ register.
     68unification hint 0 ≔
     69(*---------------*) ⊢
     70dph_reg ERTL ≡ register.
     71unification hint 0 ≔
     72(*---------------*) ⊢
     73dpl_arg ERTL ≡ psd_argument.
     74unification hint 0 ≔
     75(*---------------*) ⊢
     76dph_arg ERTL ≡ psd_argument.
     77unification hint 0 ≔
     78(*---------------*) ⊢
     79snd_arg ERTL ≡ psd_argument.
     80unification hint 0 ≔
     81(*---------------*) ⊢
     82call_args ERTL ≡ ℕ.
     83unification hint 0 ≔
     84(*---------------*) ⊢
     85call_dest ERTL ≡ unit.
     86
     87unification hint 0 ≔
     88(*---------------*) ⊢
     89ext_seq ERTL ≡ ertl_seq.
     90unification hint 0 ≔
     91(*---------------*) ⊢
     92ext_call ERTL ≡ void.
     93unification hint 0 ≔
     94(*---------------*) ⊢
     95ext_tailcall ERTL ≡ void.
     96
     97coercion reg_to_ertl_snd_argument : ∀r : register.snd_arg ERTL ≝
     98  psd_argument_from_reg
     99  on _r : register to snd_arg ERTL.
     100coercion byte_to_ertl_snd_argument : ∀b : Byte.snd_arg ERTL ≝
     101  psd_argument_from_byte
     102  on _b : Byte to snd_arg ERTL.
     103 
     104definition ertl_seq_joint ≝ extension_seq ERTL.
     105coercion ertl_seq_to_joint_seq : ∀globals.∀s : ertl_seq.joint_seq ERTL globals ≝ ertl_seq_joint
     106  on _s : ertl_seq to joint_seq ERTL.
  • src/ERTL/ERTLToLTL.ma

    r2103 r2286  
     1
    12include "LTL/LTL.ma".
    23include "ERTL/Interference.ma".
    34include "ASM/Arithmetic.ma".
    4 
    5 definition fresh_label ≝
     5include "joint/TranslateUtils.ma".
     6
     7(* Note: translation is complicated by having to preserve the carry bit and
     8  wanting to do it with as less boilerplate as possible. It could be somewhat
     9  simplified if constant and copy propagation was to be done after this pass:
     10  those optimisations would take care of the boilerplate for us.*)
     11
     12coercion Reg_to_dec : ∀r:Register.decision ≝ decision_colour on _r : Register to decision.
     13
     14inductive arg_decision : Type[0] ≝
     15  | arg_decision_colour : Register → arg_decision
     16  | arg_decision_spill : ℕ → arg_decision
     17  | arg_decision_imm : beval → arg_decision.
     18
     19coercion Reg_to_arg_dec : ∀r:Register.arg_decision ≝ arg_decision_colour on _r : Register to arg_decision.
     20
     21(* Paolo: I'm changing the following: before, spilled registers were
     22  assigned stack addresses going from SP + #frame_size - #stack_params
     23  excluded down to SP included. I am turning it upside down, so that
     24  the offset does not need the stack size to be computed *)
     25
     26definition preserve_carry_bit :
     27  ∀globals.bool → list (joint_seq LTL globals) → list (joint_seq LTL globals) ≝
     28  λglobals,do_it,steps.
     29  if do_it then SAVE_CARRY :: steps @ [RESTORE_CARRY] else steps.
     30
     31(* for notation *)
     32definition A ≝ it.
     33
     34coercion beval_of_byte : ∀b : Byte.beval ≝ BVByte on _b : Byte to beval.
     35
     36(* spill should be byte-based from the start *)
     37definition set_dp_by_offset :
     38  ∀globals.nat → list (joint_seq LTL globals) ≝
     39  λglobals,off.
     40  [ A ← byte_of_nat off
     41  ; A ← A .Add. RegisterSPL
     42  ; RegisterDPL ← A
     43  ; A ← zero_byte
     44  ; A ← A .Addc. RegisterSPH
     45  ; RegisterDPH ← A
     46  ].
     47
     48definition get_stack:
     49 ∀globals.Register → nat → list (joint_seq LTL globals) ≝
     50 λglobals,r,off.
     51 set_dp_by_offset ? off @
     52 [ LOAD … A it it ] @
     53 if eq_Register r RegisterA then [ ] else [ r ← A ].
     54
     55definition set_stack_not_a :
     56 ∀globals.nat → Register → list (joint_seq LTL globals) ≝
     57 λglobals,off,r.
     58 set_dp_by_offset ? off @
     59 [ A ← r
     60 ; STORE … it it A ].
     61
     62definition set_stack_a :
     63 ∀globals.nat → list (joint_seq LTL globals) ≝
     64 λglobals,off.
     65 [ RegisterST1 ← A ] @
     66 set_stack_not_a ? off RegisterST1.
     67
     68definition set_stack :
     69 ∀globals.nat → Register → list (joint_seq LTL globals) ≝
     70 λglobals,off,r.
     71 if eq_Register r RegisterA then
     72   set_stack_a ? off
     73 else
     74   set_stack_not_a ? off r.
     75 
     76definition set_stack_int :
     77  ∀globals.nat → beval →  list (joint_seq LTL globals) ≝
     78  λglobals,off,int.
     79  set_dp_by_offset ? off @
     80  [ A ← int
     81  ; STORE … it it A ].
     82
     83definition move :
     84  ∀globals.bool → decision → arg_decision → list (joint_seq LTL globals) ≝
     85  λglobals,carry_lives_after,dst,src.
     86  match dst with
     87  [ decision_colour dstr ⇒
     88    match src with
     89    [ arg_decision_colour srcr ⇒
     90      if eq_Register dstr srcr then [ ] else
     91      if eq_Register dstr RegisterA then [ A ← srcr ] else
     92      if eq_Register srcr RegisterA then [ dstr ← A ] else
     93      [ A ← srcr ; dstr ← A]
     94    | arg_decision_spill srco ⇒
     95      preserve_carry_bit ? carry_lives_after
     96        (get_stack ? dstr srco)
     97    | arg_decision_imm int ⇒
     98      [ A ← int ] @
     99      if eq_Register dstr RegisterA then [ ] else
     100      [ dstr ← A ]
     101    ]
     102  | decision_spill dsto ⇒
     103    match src with
     104    [ arg_decision_colour srcr ⇒
     105      preserve_carry_bit ? carry_lives_after
     106        (set_stack ? dsto srcr)
     107    | arg_decision_spill srco ⇒
     108      if eqb srco dsto then [ ] else
     109      preserve_carry_bit ? carry_lives_after
     110        (get_stack ? RegisterA srco @
     111         set_stack ? dsto RegisterA)
     112    | arg_decision_imm int ⇒
     113      preserve_carry_bit ? carry_lives_after
     114        (set_stack_int ? dsto int)
     115    ]
     116  ].
     117
     118definition arg_is_spilled : arg_decision → bool ≝
     119  λx.match x with [ arg_decision_spill _ ⇒ true | _ ⇒ false ].
     120definition is_spilled : decision → bool ≝
     121  λx.match x with [ decision_spill _ ⇒ true | _ ⇒ false ].
     122
     123definition newframe :
     124  ∀globals.ℕ → list (joint_seq LTL globals) ≝
     125  λglobals,stack_sz.
     126  [ CLEAR_CARRY …
     127  ; A ← RegisterSPL
     128  ; A ← A .Sub. byte_of_nat stack_sz
     129  ; RegisterSPL ← A
     130  ; A ← RegisterSPH
     131  ; A ← A .Sub. zero_byte
     132  ; RegisterSPL ← A
     133  ].
     134
     135definition delframe :
     136  ∀globals.ℕ → list (joint_seq LTL globals) ≝
     137  λglobals,stack_sz.
     138  [ A ← RegisterSPL
     139  ; A ← A .Add. byte_of_nat stack_sz
     140  ; RegisterSPL ← A
     141  ; A ← RegisterSPH
     142  ; A ← A .Addc. zero_byte
     143  ; RegisterSPL ← A
     144  ].
     145
     146definition commutative : Op2 → bool ≝
     147λop.match op with
     148[ Add ⇒ true
     149| Addc ⇒ true
     150| Or ⇒ true
     151| Xor ⇒ true
     152| And ⇒ true
     153| _ ⇒ false
     154].
     155
     156definition uses_carry : Op2 → bool ≝
     157λop.match op with
     158[ Addc ⇒ true
     159| Sub ⇒ true
     160| _ ⇒ false
     161].
     162
     163definition sets_carry : Op2 → bool ≝
     164λop.match op with
     165[ Add ⇒ true
     166| Addc ⇒ true
     167| Sub ⇒ true
     168| _ ⇒ false
     169].
     170
     171definition translate_op2 :
     172  ∀globals.bool→ Op2 → decision → arg_decision → arg_decision → list (joint_seq LTL globals) ≝
     173  λglobals,carry_lives_after,op,dst,arg1,arg2.
     174  (* this won't preserve the carry bit if op does not set it: left to next function *)
     175  (* if op uses carry bit (⇒ it sets it too) it must be preserved before the op *)
     176  (preserve_carry_bit ?
     177    (uses_carry op ∧ (arg_is_spilled arg1 ∨ arg_is_spilled arg2))
     178    (move ? false RegisterB arg2 @
     179     move ? false RegisterA arg1) @
     180    [ A ← A .op. RegisterB ] @
     181    (* it op sets the carry bit and it is needed afterwards it must be preserved here *)
     182    move ? (sets_carry op ∧ carry_lives_after) dst RegisterA).
     183
     184definition translate_op2_smart :
     185  ∀globals.bool → Op2 → decision → arg_decision → arg_decision → list (joint_seq LTL globals) ≝
     186  λglobals,carry_lives_after,op,dst,arg1,arg2.
     187  (* if op does not set carry bit (⇒ it does not use it either) then it must be
     188    preserved *)
     189  preserve_carry_bit ?
     190    (¬sets_carry op ∧ carry_lives_after ∧
     191      (arg_is_spilled arg1 ∨ arg_is_spilled arg2 ∨ is_spilled dst))
     192    (match arg2 with
     193    [ arg_decision_colour arg2r ⇒
     194      move ? (uses_carry op) RegisterA arg1 @
     195      [ A ← A .op. arg2r ] @
     196      move ? (sets_carry op ∧ carry_lives_after) dst RegisterA
     197    | arg_decision_imm arg2i ⇒
     198      move ? (uses_carry op) RegisterA arg1 @
     199      [ A ← A .op. arg2i ] @
     200      move ? (sets_carry op ∧ carry_lives_after) dst RegisterA
     201    | _ ⇒
     202      if commutative op then
     203        match arg1 with
     204        [ arg_decision_colour arg1r ⇒
     205          move ? (uses_carry op) RegisterA arg2 @
     206          [ A ← A .op. arg1r ] @
     207          move ? (sets_carry op ∧ carry_lives_after) dst RegisterA
     208        | arg_decision_imm arg1i ⇒
     209          move ? (uses_carry op) RegisterA arg2 @
     210          [ A ← A .op. arg1i ] @
     211          move ? (sets_carry op ∧ carry_lives_after) dst RegisterA
     212        | _ ⇒
     213          translate_op2 ? carry_lives_after op dst arg1 arg2
     214        ]
     215      else
     216        translate_op2 ? carry_lives_after op dst arg1 arg2
     217    ]).
     218
     219definition dec_to_arg_dec : decision → arg_decision ≝
     220  λd.match d with
     221  [ decision_colour r ⇒ arg_decision_colour r
     222  | decision_spill n ⇒ arg_decision_spill n
     223  ].
     224
     225coercion dec_arg_dec : ∀d:decision.arg_decision ≝ dec_to_arg_dec on _d : decision to arg_decision.
     226
     227definition translate_op1 :
     228  ∀globals.bool → Op1 → decision → decision → list (joint_seq LTL globals) ≝
     229  λglobals,carry_lives_after,op,dst,arg.
     230  let preserve_carry ≝ carry_lives_after ∧ (is_spilled dst ∨ is_spilled arg) in
     231  preserve_carry_bit ? preserve_carry
     232    (move ? false RegisterA arg @
     233     OP1 … op it it ::
     234     move ? false dst RegisterA).
     235
     236definition translate_opaccs :
     237  ∀globals.bool → OpAccs → decision → decision → arg_decision → arg_decision → list (joint_seq LTL globals) ≝
     238  λglobals,carry_lives_after,op,dst1,dst2,arg1,arg2.
     239  (* OPACCS always has dead carry bit and sets it to zero *)
     240  move ? false RegisterB arg2 @
     241  move ? false RegisterA arg1 @
     242  OPACCS … op it it it it ::
     243  move ? false dst1 RegisterA @
     244  move ? false dst2 RegisterB @
     245  if carry_lives_after ∧ (is_spilled dst1 ∨ is_spilled dst2) then
     246    [CLEAR_CARRY ??]
     247  else [ ].
     248
     249(* does not preserve carry bit *)
     250definition move_to_dp :
     251  ∀globals.arg_decision → arg_decision → list (joint_seq LTL globals) ≝
     252  λglobals,arg1,arg2.
     253  if ¬arg_is_spilled arg1 then
     254    move ? false RegisterDPH arg2 @
     255    (* does not change dph because arg1 is not spilled *)
     256    move ? false RegisterDPL arg1
     257  else if ¬arg_is_spilled arg2 then
     258    move ? false RegisterDPL arg1 @
     259    (* does not change dpl because arg2 is not spilled *)
     260    move ? false RegisterDPH arg2
     261  else
     262    (* using B as temporary, as moving spilled registers tampers with DPTR *)
     263    move ? false RegisterB arg1 @
     264    move ? false RegisterDPH arg2 @
     265    move ? false RegisterDPL RegisterB.
     266
     267definition translate_store : 
     268  ∀globals.bool → arg_decision → arg_decision → arg_decision → list (joint_seq LTL globals) ≝
     269  λglobals,carry_lives_after,addr1,addr2,src.
     270  (* requires src != RegisterA and RegisterB *)
     271  preserve_carry_bit ? (carry_lives_after ∧
     272    (arg_is_spilled addr1 ∨ arg_is_spilled addr1 ∨ arg_is_spilled src))
     273    (let move_to_dptr ≝ move_to_dp ? addr1 addr2 in
     274     (if arg_is_spilled src then
     275        move ? false RegisterST0 src @
     276        move_to_dptr @
     277        [ A ← RegisterST0]
     278      else move_to_dptr) @
     279     [STORE … it it A]).
     280
     281definition translate_load : 
     282  ∀globals.bool → decision → arg_decision → arg_decision → list (joint_seq LTL globals) ≝
     283  λglobals,carry_lives_after,dst,addr1,addr2.
     284  preserve_carry_bit ? (carry_lives_after ∧
     285    (is_spilled dst ∨ arg_is_spilled addr1 ∨ arg_is_spilled addr1))
     286    (move_to_dp ? addr1 addr2 @
     287     [ LOAD … A it it ] @
     288     move ? false dst RegisterA).
     289
     290definition translate_address :
     291  ∀globals.bool → ∀i.member i (eq_identifier ?) globals → decision → decision →
     292  list (joint_seq LTL globals) ≝
     293  λglobals,carry_lives_after,id,prf,addr1,addr2.
     294  preserve_carry_bit ? (carry_lives_after ∧ (is_spilled addr1 ∨ is_spilled addr2))
     295    (ADDRESS LTL ? id prf it it ::
     296     move ? false addr1 RegisterDPL @
     297     move ? false addr2 RegisterDPH).
     298
     299definition translate_step:
     300  ∀globals.∀after : valuation register_lattice.
     301  coloured_graph after →
     302  ℕ → label → joint_step ERTL globals → seq_block LTL globals (joint_step LTL globals) ≝
     303  λglobals,after,grph,stack_sz,lbl,s.
     304  let lookup ≝ λr.colouring … grph (inl … r) in
     305  let lookup_arg ≝ λa.match a with
     306    [ Reg r ⇒ lookup r
     307    | Imm b ⇒ arg_decision_imm b
     308    ] in
     309  let carry_lives_after ≝ hlives RegisterCarry (after lbl) in
     310  let move ≝ move globals carry_lives_after in
     311  match s with
     312  [ step_seq s' ⇒
     313    match s' return λ_.seq_block LTL globals (joint_step LTL globals) with
     314    [ COMMENT c ⇒ COMMENT … c
     315    | COST_LABEL cost_lbl ⇒ COST_LABEL … cost_lbl
     316    | POP r ⇒
     317      POP … A ::
     318      move (lookup r) RegisterA
     319    | PUSH a ⇒
     320      move RegisterA (lookup_arg a) @
     321      [ PUSH … A ]
     322    | STORE addr1 addr2 srcr ⇒
     323      translate_store ? carry_lives_after
     324        (lookup_arg addr1)
     325        (lookup_arg addr2)
     326        (lookup_arg srcr)
     327    | LOAD dstr addr1 addr2 ⇒
     328      translate_load ? carry_lives_after
     329        (lookup dstr)
     330        (lookup_arg addr1)
     331        (lookup_arg addr2)
     332    | CLEAR_CARRY ⇒ CLEAR_CARRY …
     333    | SET_CARRY ⇒ CLEAR_CARRY …
     334    | OP2 op dst arg1 arg2 ⇒
     335      translate_op2_smart ? carry_lives_after op
     336        (lookup dst)
     337        (lookup_arg arg1)
     338        (lookup_arg arg2)
     339    | OP1 op dst arg ⇒
     340      translate_op1 ? carry_lives_after op
     341        (lookup dst)
     342        (lookup arg)
     343    | MOVE pair_regs ⇒
     344      let lookup_move_dst ≝ λx.match x return λ_.decision with
     345        [ PSD r ⇒ lookup r
     346        | HDW r ⇒ r
     347        ] in
     348      let dst ≝ lookup_move_dst (\fst pair_regs) in
     349      let src ≝
     350        match \snd pair_regs return λ_.arg_decision with
     351        [ Reg r ⇒ lookup_move_dst r
     352        | Imm b ⇒ arg_decision_imm b
     353        ] in
     354      move dst src
     355    | ADDRESS lbl prf dpl dph ⇒
     356      translate_address ? carry_lives_after
     357        lbl prf (lookup dpl) (lookup dph)
     358    | OPACCS op dst1 dst2 arg1 arg2 ⇒
     359      translate_opaccs ? carry_lives_after op
     360        (lookup dst1) (lookup dst2)
     361        (lookup_arg arg1) (lookup_arg arg2)
     362    | extension_seq ext ⇒
     363      match ext with
     364      [ ertl_new_frame ⇒ newframe ? stack_sz
     365      | ertl_del_frame ⇒ delframe ? stack_sz
     366      | ertl_frame_size r ⇒
     367        move (lookup r) (arg_decision_imm (byte_of_nat stack_sz))
     368      ]
     369    | CALL_ID f n_args _ ⇒ CALL_ID LTL ? f n_args it
     370    | extension_call abs ⇒ match abs in void with [ ]
     371    ]
     372  | COND r ltrue ⇒
     373    〈move RegisterA (lookup r),COND … it ltrue〉
     374  ].
     375
     376definition translate_fin_step:
     377  ∀globals.label → joint_fin_step ERTL → seq_block LTL globals (joint_fin_step LTL) ≝
     378  λglobals,lbl,s.
     379  match s return λ_.seq_block LTL globals (joint_fin_step LTL) with
     380  [ RETURN ⇒ RETURN ?
     381  | GOTO l ⇒ GOTO ? l
     382  | tailcall abs ⇒ match abs in void with [ ]
     383  ].
     384
     385definition translate_internal: ∀globals: list ident.
     386  joint_internal_function ERTL globals →
     387  joint_internal_function LTL globals ≝
    6388  λglobals: list ident.
    7   λluniv.
    8     fresh LabelTag luniv.
    9 
    10 definition ltl_statement_graph ≝
    11   λglobals.
    12     graph … (ltl_statement globals).
    13 
    14 definition add_graph ≝
    15   λglobals.
    16   λlabel.
    17   λstmt: ltl_statement globals.
    18   λgraph: ltl_statement_graph globals.
    19     add LabelTag ? graph label stmt.
    20 
    21 definition generate ≝
    22   λglobals: list ident.
    23   λluniv.
    24   λgraph: ltl_statement_graph globals.
    25   λstmt: ltl_statement globals.
    26   let 〈l, luniv〉 ≝ fresh_label globals luniv in
    27   let graph ≝ add_graph globals l stmt graph in
    28     〈l, graph, luniv〉.
    29 
    30 definition num_locals ≝
    31   λspilled_no.
    32   λglobals.
    33   λint_fun.
    34     spilled_no + (joint_if_stacksize globals (ertl_params globals) int_fun).
    35 
    36 definition stacksize ≝
    37   λspilled_no.
    38   λglobals.
    39   λint_fun.
    40     spilled_no + (joint_if_stacksize globals (ertl_params globals) int_fun).
    41 
    42 definition adjust_off ≝
    43   λspilled_no.
    44   λglobals.
    45   λint_fun.
    46   λoff.
    47   let 〈ignore, int_off〉 ≝ half_add ? int_size off in
    48   let 〈sub, ignore〉 ≝ sub_8_with_carry (bitvector_of_nat ? (num_locals spilled_no globals int_fun)) int_off false in
    49     sub.
    50 
    51 definition get_stack:
    52  nat → ∀globals. ertl_internal_function globals → graph (ltl_statement globals) → Register → Byte → label → ? ≝
    53   λspilled_no.
    54   λglobals: list ident.
    55   λint_fun.
    56   λgraph: graph (ltl_statement (globals)).
    57   λr.
    58   λoff.
    59   λl.
    60   λoriginal_label.
    61     let off ≝ adjust_off spilled_no globals int_fun off in
    62     let luniv ≝ joint_if_luniverse globals (ertl_params globals) int_fun in
    63     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc r)) l) in
    64     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (LOAD … globals it it it) l) in
    65     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc RegisterDPH)) l) in
    66     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (OP2 … globals Addc it it RegisterSPH) l) in
    67     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (INT … globals RegisterA (zero ?)) l) in
    68     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc RegisterDPL)) l) in
    69     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (OP2 … globals Add it it RegisterSPL) l) in
    70       〈add_graph globals original_label (sequential (ltl_params globals) globals (INT … (ltl_params globals) globals RegisterA off) l) graph, luniv〉.
    71 
    72 definition set_stack:
    73   nat → ∀globals. ertl_internal_function globals → ltl_statement_graph globals → Byte
    74     → Register → label → ? ≝
    75   λspilled_no.
    76   λglobals: list ident.
    77   λint_fun.
    78   λgraph: graph (ltl_statement (globals)).
    79   λoff.
    80   λr.
    81   λl.
    82   λoriginal_label.
    83   let off ≝ adjust_off spilled_no globals int_fun off in
    84   let luniv ≝ joint_if_luniverse globals (ertl_params globals) int_fun in
    85   let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (STORE … globals it it it) l) in
    86   let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (to_acc r)) l) in
    87   let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc RegisterDPH)) l) in
    88   let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (OP2 … globals Addc it it RegisterSPH) l) in
    89   let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (INT … globals RegisterA (zero ?)) l) in
    90   let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc RegisterDPL)) l) in
    91   let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (OP2 … globals Add it it RegisterSPL) l) in
    92     〈add_graph globals original_label (sequential (ltl_params globals) globals (INT … (ltl_params globals) globals RegisterA off) l) graph, luniv〉.
    93 
    94 
    95 definition write ≝
    96   λglobals: list ident.
    97   λint_fun: ertl_internal_function globals.
    98   λvaluation.
    99   λcoloured_graph.
    100   λgraph.
    101   λr.
    102   λl.
    103   λoriginal_label: label.
    104   match colouring valuation coloured_graph (inl … r) with
    105   [ decision_spill off ⇒
    106     let luniv ≝ joint_if_luniverse … int_fun in
    107     let 〈graph, luniv〉 ≝ set_stack (spilled_no … coloured_graph) globals int_fun graph (bitvector_of_nat … off) RegisterSST l original_label in
    108       〈RegisterSST, l, graph, luniv〉
    109   | decision_colour hwr ⇒
    110     let luniv ≝ joint_if_luniverse globals (ertl_params globals) int_fun in
    111       〈hwr, l, graph, luniv〉
    112   ].
    113 
    114 definition read ≝
    115   λglobals: list ident.
    116   λint_fun: ertl_internal_function globals.
    117   λvaluation.
    118   λcoloured_graph.
    119   λgraph.
    120   λr.
    121   λstmt.
    122   λoriginal_label: label.
    123   match colouring valuation coloured_graph (inl … r) with
    124   [ decision_colour hwr ⇒
    125     let luniv ≝ joint_if_luniverse … int_fun in
    126       〈add_graph globals original_label (stmt hwr) graph, luniv〉
    127   | decision_spill off ⇒
    128     let temphwr ≝ RegisterSST in
    129     let luniv ≝ joint_if_luniverse … int_fun in
    130     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (stmt temphwr) in
    131       get_stack (spilled_no … coloured_graph) globals int_fun graph temphwr (bitvector_of_nat … off) l original_label
    132   ].
    133 
    134 definition move ≝
    135   λspilled_no.
    136   λglobals: list ident.
    137   λint_fun.
    138   λgraph: graph (ltl_statement globals).
    139   λdest: decision.
    140   λsrc: decision.
    141   λl: label.
    142   λoriginal_label: label.
    143   match dest with
    144   [ decision_colour dest_hwr ⇒
    145     match src with
    146     [ decision_colour src_hwr ⇒
    147       let luniv ≝ joint_if_luniverse globals (ertl_params globals) int_fun in
    148       if eq_Register dest_hwr src_hwr then
    149         〈add_graph globals original_label (GOTO … globals l) graph, luniv〉
    150       else
    151         let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc dest_hwr)) l) in
    152           〈add_graph globals original_label (sequential (ltl_params globals) globals (MOVE … globals (to_acc src_hwr)) l) graph, luniv〉
    153     | decision_spill src_off ⇒ get_stack spilled_no globals int_fun graph dest_hwr (bitvector_of_nat … src_off) l original_label
    154     ]
    155   | decision_spill dest_off ⇒
    156     match src with
    157     [ decision_colour src_hwr ⇒ set_stack spilled_no globals int_fun graph (bitvector_of_nat … dest_off) src_hwr l original_label
    158     | decision_spill src_off ⇒
    159       let luniv ≝ joint_if_luniverse globals (ertl_params globals) int_fun in
    160       if eq_nat dest_off src_off then
    161         〈add_graph globals original_label (GOTO … globals l) graph, luniv〉
    162       else
    163         let temp_hwr ≝ RegisterSST in
    164         let 〈graph, luniv〉 ≝ set_stack spilled_no globals int_fun graph (bitvector_of_nat … dest_off) temp_hwr l original_label in
    165           get_stack spilled_no globals int_fun graph temp_hwr (bitvector_of_nat … src_off) l original_label
    166     ]
    167   ].
    168 
    169 definition newframe ≝
    170   λspilled_no.
    171   λglobals: list ident.
    172   λint_fun: ertl_internal_function globals.
    173   λgraph: ltl_statement_graph globals.
    174   λl: label.
    175   λoriginal_label: label.
    176   if eq_nat (stacksize spilled_no globals int_fun) 0 then
    177     let luniv ≝ joint_if_luniverse globals (ertl_params globals) int_fun in
    178       〈add_graph globals original_label (GOTO … globals l) graph, luniv〉
    179   else
    180     let luniv ≝ joint_if_luniverse globals (ertl_params globals) int_fun in
    181     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc RegisterSPH)) l) in
    182     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (OP2 … globals Sub it it RegisterDPH) l) in
    183     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (INT … globals RegisterDPH (zero ?)) l) in
    184     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (to_acc RegisterSPH)) l) in
    185     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc RegisterSPL)) l) in
    186     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (OP2 … globals Sub it it RegisterDPL) l) in
    187     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (CLEAR_CARRY … globals) l) in
    188     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (INT … globals RegisterDPL (bitvector_of_nat ? (stacksize spilled_no globals int_fun))) l) in
    189       〈add_graph globals original_label (sequential (ltl_params globals) globals (MOVE … globals (to_acc RegisterSPL)) l) graph, luniv〉.
    190 
    191 definition delframe ≝
    192   λspilled_no.
    193   λglobals.
    194   λint_fun.
    195   λgraph: graph (ltl_statement globals).
    196   λl.
    197   λoriginal_label: label.
    198   if eq_nat (stacksize spilled_no globals int_fun) 0 then
    199     let luniv ≝ joint_if_luniverse globals (ertl_params globals) int_fun in
    200       〈add_graph globals original_label (GOTO (ltl_params globals) globals l) graph, luniv〉
    201   else
    202     let luniv ≝ joint_if_luniverse globals (ertl_params globals) int_fun in
    203     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc RegisterSPH)) l) in
    204     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (OP2 … globals Addc it it RegisterSPH) l) in
    205     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (INT … globals RegisterA (zero ?)) l) in
    206     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc RegisterSPL)) l) in
    207     let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (OP2 … globals Add it it RegisterSPL) l) in
    208       〈add_graph globals original_label (sequential (ltl_params globals) globals (INT ? globals RegisterA (bitvector_of_nat ? (stacksize spilled_no globals int_fun))) l) graph, luniv〉.
    209 
    210 definition translate_statement:
    211   ∀globals: list ident. ertl_internal_function globals → ∀v: valuation.
    212     coloured_graph v → ltl_statement_graph globals → ertl_statement globals →
    213       label → ((ltl_statement_graph globals) × (universe LabelTag)) ≝
    214   λglobals: list ident.
    215   λint_fun.
    216   λvaluation.
    217   λcoloured_graph: coloured_graph valuation.
    218   λgraph: ltl_statement_graph globals.
    219   λstmt: ertl_statement globals.
    220   λoriginal_label: label.
    221   match stmt with
    222   [ sequential seq l ⇒
    223     let luniv ≝ joint_if_luniverse globals (ertl_params globals) int_fun in
    224     match seq with
    225     [ COMMENT c ⇒
    226       〈add_graph globals original_label (sequential … (COMMENT … c) l) graph, luniv〉
    227     | COST_LABEL cost_lbl ⇒
    228       〈add_graph globals original_label (sequential … (COST_LABEL … cost_lbl) l) graph, luniv〉
    229     | POP r ⇒
    230       let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
    231       let int_fun ≝ set_luniverse globals ? int_fun luniv in
    232       let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun valuation coloured_graph graph r l fresh_lbl in
    233       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc hdw)) l) in
    234         〈add_graph globals original_label (sequential ltl_params_ globals (POP … it) l) graph, luniv〉
    235     | PUSH r ⇒
    236       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (PUSH … globals it) 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 r (λhdw. sequential … (MOVE … (to_acc hdw)) l) fresh_lbl in
    241         〈add_graph globals original_label (GOTO … fresh_lbl) graph, luniv〉
    242     | COND srcr lbl_true ⇒
    243       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (COND … it lbl_true) l) in
    244       let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
    245       let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
    246       let int_fun' ≝ set_luniverse globals ? int_fun luniv in
    247       let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph srcr (λhdw. sequential … (MOVE … (to_acc hdw)) l) fresh_lbl in
    248         〈add_graph globals original_label (GOTO … fresh_lbl) graph, luniv〉
    249     | CALL_ID f ignore ignore' ⇒ 〈add_graph globals original_label (sequential … (CALL_ID … f ignore ignore') l) graph, luniv〉
    250     | STORE addr1 addr2 srcr ⇒
    251       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (STORE … it it it) l) in
    252       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (to_acc RegisterST1)) l) in
    253       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc RegisterDPH)) l) in
    254       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (to_acc RegisterST0)) l) in
    255       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc RegisterDPL)) l) in
    256       let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
    257       let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
    258       let int_fun ≝ set_luniverse globals ? int_fun luniv in
    259       let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph addr1 (λhdw. sequential … (MOVE … (to_acc hdw)) l) fresh_lbl in
    260       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc RegisterST0)) fresh_lbl) in
    261       let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
    262       let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
    263       let int_fun ≝ set_luniverse globals ? int_fun luniv in
    264       let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph addr2 (λhdw. sequential … (MOVE … (to_acc hdw)) l) fresh_lbl in
    265       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc RegisterST1)) fresh_lbl) in
    266       let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
    267       let int_fun ≝ set_luniverse globals ? int_fun luniv in
    268       let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph srcr (λhdw. sequential … (MOVE … (to_acc hdw)) l) fresh_lbl in
    269         〈add_graph globals original_label (GOTO … l) graph, luniv〉
    270     | LOAD destr addr1 addr2 ⇒
    271       let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
    272       let int_fun ≝ set_luniverse globals ? int_fun luniv in
    273       let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun valuation coloured_graph graph destr l fresh_lbl in
    274       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc hdw)) l) in
    275       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (LOAD … it it it) l) in
    276       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc RegisterDPH)) l) in
    277       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (to_acc RegisterST0)) l) in
    278       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc RegisterDPL)) l) in
    279       let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
    280       let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
    281       let int_fun ≝ set_luniverse globals ? int_fun luniv in
    282       let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph addr1 (λhdw. sequential … (MOVE … (to_acc hdw)) l) fresh_lbl in
    283       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc RegisterST0)) fresh_lbl) in
    284       let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
    285       let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
    286       let int_fun ≝ set_luniverse globals ? int_fun luniv in
    287       let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph addr2 (λhdw. sequential … (MOVE … (to_acc hdw)) l) fresh_lbl in
    288         〈add_graph globals original_label (GOTO … fresh_lbl) graph, luniv〉
    289     | CLEAR_CARRY ⇒ 〈add_graph globals original_label (sequential … (CLEAR_CARRY …) l) graph, luniv〉
    290     | SET_CARRY ⇒ 〈add_graph globals original_label (sequential … (SET_CARRY …) l) graph, luniv〉
    291     | OP2 op2 destr srcr1 srcr2 ⇒
    292       let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
    293       let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
    294       let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun valuation coloured_graph graph destr l fresh_lbl in
    295       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc hdw)) l) in
    296       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (OP2 … op2 it it RegisterB) l) in
    297       let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
    298       let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
    299       let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph srcr1 (λhdw. sequential … (MOVE … (to_acc hdw)) l) fresh_lbl in
    300       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc RegisterB)) fresh_lbl) in
    301       let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
    302       let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
    303       let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph srcr2 (λhdw. sequential … (MOVE … (to_acc hdw)) l) fresh_lbl in
    304         〈add_graph globals original_label (GOTO … l) graph, luniv〉
    305     | OP1 op1 destr srcr ⇒
    306       let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
    307       let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
    308       let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun valuation coloured_graph graph destr l fresh_lbl in
    309       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc hdw)) l) in
    310       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (OP1 … op1 it it) l) in
    311       let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
    312       let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
    313       let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
    314       let 〈graph, luniv〉 ≝ read globals int_fun valuation coloured_graph graph srcr (λhdw. sequential … (MOVE … (to_acc hdw)) l) fresh_lbl in
    315         〈add_graph globals original_label (GOTO … l) graph, luniv〉
    316     | INT r i ⇒
    317       let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
    318       let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
    319       let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun valuation coloured_graph graph r l fresh_lbl in
    320         〈add_graph globals original_label (sequential ltl_params_ globals (INT … hdw i) l) graph, luniv〉
    321     | MOVE pair_regs ⇒
    322       let regl ≝ \fst pair_regs in
    323       let regr ≝ \snd pair_regs in
    324       match regl with
    325       [ pseudo p1  ⇒
    326         match regr with
    327         [ pseudo p2  ⇒ move (spilled_no … coloured_graph) globals int_fun graph (colouring valuation coloured_graph (inl … p1)) (colouring valuation coloured_graph (inl … p2)) l original_label
    328         | hardware h ⇒ move (spilled_no … coloured_graph) globals int_fun graph (colouring valuation coloured_graph (inl … p1)) (decision_colour h) l original_label
    329         ]
    330       | hardware h1 ⇒
    331         match regr with
    332         [ pseudo p    ⇒ move (spilled_no … coloured_graph) globals int_fun graph (decision_colour h1) (colouring valuation coloured_graph (inl … p)) l original_label
    333         | hardware h2 ⇒
    334           let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc h1)) l) in
    335             〈add_graph globals original_label (sequential ltl_params_ … (MOVE … (to_acc h2)) l) graph, luniv〉
    336         ]
    337       ]
    338     | ADDRESS lbl prf dpl dph ⇒
    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 〈hdw1, l, graph, luniv〉 ≝ write globals int_fun valuation coloured_graph graph dph l fresh_lbl in
    342       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc hdw1)) l) in
    343       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (to_acc RegisterDPH)) l) in
    344       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (ADDRESS … globals lbl prf it it) l) in
    345       let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
    346       let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
    347       let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
    348       let 〈hdw2, l, graph, luniv〉 ≝ write globals int_fun valuation coloured_graph graph dpl l fresh_lbl in
    349       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc hdw2)) l) in
    350       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (to_acc RegisterDPL)) l) in
    351         〈add_graph globals original_label (sequential ltl_params_ globals (ADDRESS … lbl prf it it) l) graph, luniv〉
    352     | extension ext ⇒
    353       match ext with
    354       [ ertl_st_ext_new_frame ⇒ newframe (spilled_no … coloured_graph)globals int_fun graph l original_label
    355       | ertl_st_ext_del_frame ⇒ delframe (spilled_no … coloured_graph) globals int_fun graph l original_label
    356       | ertl_st_ext_frame_size r ⇒
    357         let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
    358         let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
    359         let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun valuation coloured_graph graph r l fresh_lbl in
    360           〈add_graph globals original_label (sequential ltl_params_ globals (INT … hdw (bitvector_of_nat … (stacksize (spilled_no … coloured_graph) … int_fun))) l) graph, luniv〉
    361       ]
    362     | OPACCS opaccs dacc_a_reg dacc_b_reg sacc_a_reg sacc_b_reg ⇒
    363       let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
    364       let 〈hdw, l, graph, luniv〉 ≝ write globals int_fun valuation coloured_graph graph dacc_a_reg l fresh_lbl in
    365       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (MOVE … (from_acc hdw)) l) in
    366       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … (OPACCS … opaccs it it it it) l) in
    367       let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
    368       let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
    369       let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
    370       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
    371       let 〈l, graph, luniv〉 ≝ generate globals luniv graph (sequential … globals (MOVE … globals (from_acc RegisterB)) fresh_lbl) in
    372       let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
    373       let 〈fresh_lbl, luniv〉 ≝ fresh_label globals luniv in
    374       let int_fun ≝ set_luniverse globals (ertl_params globals) int_fun luniv in
    375       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
    376         〈add_graph globals original_label (GOTO … globals fresh_lbl) graph, luniv〉
    377     ]
    378   | RETURN ⇒ 〈add_graph globals original_label (RETURN ltl_params_ globals) graph, joint_if_luniverse globals (ertl_params globals) int_fun〉
    379   | GOTO l ⇒ 〈add_graph globals original_label (GOTO ltl_params_ globals l) graph, joint_if_luniverse globals (ertl_params globals) int_fun〉
    380   ].
    381 
    382 definition graph_fold ≝
    383   λglobals.
    384   λb : Type[0].
    385   λf    : label → ertl_statement globals → b → b.
    386   λgraph: graph (ertl_statement globals).
    387   λseed : b.
    388     foldi (ertl_statement globals) b ? f graph seed.
    389 
    390 definition translate_internal: ∀globals: list ident.
    391   ertl_internal_function globals → ltl_internal_function globals ≝
    392   λglobals: list ident.
    393   λint_fun: ertl_internal_function globals.
    394   let graph ≝ (empty_map … : ltl_statement_graph globals) in
    395   let valuation ≝ analyse globals int_fun in
    396   let coloured_graph ≝ build valuation in
    397   let 〈graph, luniv〉 ≝ graph_fold globals ((ltl_statement_graph globals) × (universe LabelTag)) (λlabel: label. λstmt: ertl_statement globals. λgraph_luniv: (? × (universe LabelTag)).
    398     let 〈graph, luniv〉 ≝ graph_luniv in
    399       match eliminable globals (valuation label) stmt with
    400       [ Some successor ⇒ 〈add_graph globals label (GOTO … successor) graph, luniv〉
    401       | None           ⇒
    402         translate_statement globals int_fun valuation coloured_graph graph stmt label
    403       ]) (joint_if_code globals (ertl_params globals) int_fun) 〈graph, joint_if_luniverse … int_fun〉
    404   in
    405     match joint_if_entry … int_fun with
    406     [ mk_Sig entry_label entry_label_prf ⇒
    407       match joint_if_exit … int_fun with
    408       [ mk_Sig exit_label exit_label_prf ⇒
    409           mk_joint_internal_function globals (ltl_params globals)
    410             luniv (joint_if_runiverse … int_fun)
    411               it it it (joint_if_stacksize … int_fun)
    412                 graph ? ?
    413       ]
    414     ].
    415   [1: %
    416     [1: @entry_label
    417     |2: cases daemon (* XXX *)
    418     ]
    419   |2: %
    420     [1: @exit_label
    421     |2: cases daemon (* XXX *)
    422     ]
    423   ]
    424 qed.
     389  λint_fun: joint_internal_function ERTL globals.
     390  (* initialize graph *)
     391  let entry ≝ pi1 … (joint_if_entry … int_fun) in
     392  let exit ≝ pi1 … (joint_if_exit … int_fun) in
     393  (* colour registers *)
     394  let after ≝ analyse_liveness globals int_fun in
     395  let coloured_graph ≝ build after in
     396  (* compute new stack size *)
     397  let stack_sz ≝ spilled_no … coloured_graph + joint_if_stacksize … int_fun in
     398  (* initialize internal function *)
     399  let init ≝ init_graph_if LTL globals
     400    (joint_if_luniverse … int_fun)
     401    (joint_if_runiverse … int_fun)
     402    it it [ ] stack_sz entry exit in
     403  graph_translate …
     404    init
     405    (translate_step … coloured_graph stack_sz)
     406    (translate_fin_step …)
     407    int_fun.
    425408
    426409definition ertl_to_ltl: ertl_program → ltl_program ≝
  • src/ERTL/Interference.ma

    r1730 r2286  
    1 include "ERTL/ERTL.ma".
    21include "ERTL/liveness.ma".
    3 
    4 definition vertex ≝ register ⊎ Register.
    52
    63inductive decision: Type[0] ≝
    74  | decision_spill: nat → decision
    85  | decision_colour: Register → decision.
    9 
    10 definition is_member ≝
    11   λvertex.
    12   λregister_lattice.
    13   let 〈l, r〉 ≝ register_lattice in
    14   match vertex with
    15   [ inl v ⇒ set_member ? (eq_identifier RegisterTag) v l
    16   | inr v ⇒ set_member ? eq_Register v r
    17   ].
    186
    197(* prop_colouring is the non interferece
     
    2210(* Wilmer: the generation of the destruct principle diverges;
    2311   Ctr-C make the file pass *)
    24 record coloured_graph (v: valuation): Type[1] ≝
     12record coloured_graph (after: valuation register_lattice): Type[1] ≝
    2513{ colouring: vertex → decision
    2614; spilled_no: nat
    2715; prop_colouring: ∀l. ∀v1, v2: vertex.
    28    is_member v1 (v l) → is_member v2 (v l) → colouring v1 ≠ colouring v2
    29 ; prop_colouring2: (*CSC: the exist-guarded premise is just to make the proof more general *)
    30    ∀v1:vertex. (∃l. bool_to_Prop (is_member v1 (v l))) → ∀i. colouring v1 = decision_spill i → lt i spilled_no
    31 (* CSC: useless for the proof and very weak
    32 ; prop_colouring3:
    33    spilled_no = 0 ∨
    34     ∃l.∃v1:vertex. bool_to_Prop (is_member v1 (v l)) ∧ colouring v1 = decision_spill (minus spilled_no 1)
    35 *)
     16  lives v1 (after l) → lives v2 (after l) → colouring v1 ≠ colouring v2
     17; prop_spilled_no: (*CSC: the exist-guarded premise is just to make the proof more general *)
     18   ∀v1:vertex. (∃l. bool_to_Prop (lives v1 (after l))) → ∀i. colouring v1 = decision_spill i → i < spilled_no
    3619}.
    3720
  • src/ERTL/liveness.ma

    r1995 r2286  
     1
    12include "ASM/Util.ma".
    23include "ERTL/ERTL.ma".
    34include "utilities/adt/set_adt.ma".
    4 
    5 definition statement_successors ≝
    6   λglobals: list ident.
    7   λs: ertl_statement globals.
     5include "utilities/fixpoints.ma".
     6
     7definition register_lattice : property_lattice ≝
     8mk_property_lattice
     9 ((set register) × (set Register))
     10 〈set_empty …, set_empty …〉
     11 (λleft.
     12  λright.
     13  set_equal … (eq_identifier ?) (\fst left) (\fst right) ∧
     14  set_equal … eq_Register (\snd left) (\snd right))
     15 (λleft.
     16  λright.
     17  set_subset … (eq_identifier ?) (\fst left) (\fst right) ∧
     18  set_subset … eq_Register (\snd left) (\snd right))
     19 (λ_.false).
     20
     21definition rl_bottom ≝ l_bottom register_lattice.
     22definition rl_psingleton: register → register_lattice ≝
     23  λr.
     24    〈set_singleton … r, set_empty …〉.
     25definition rl_hsingleton: Register → register_lattice ≝
     26  λr.
     27    〈set_empty …, set_singleton … r〉.
     28
     29definition rl_join: register_lattice → register_lattice → register_lattice ≝
     30  λleft.
     31  λright.
     32  let 〈lp, lh〉 ≝ left in
     33  let 〈rp, rh〉 ≝ right in
     34    〈set_union … lp rp, set_union … lh rh〉.
     35
     36definition rl_diff: register_lattice → register_lattice → register_lattice ≝
     37  λleft.
     38  λright.
     39  let 〈lp, lh〉 ≝ left in
     40  let 〈rp, rh〉 ≝ right in
     41    〈set_diff … lp rp, set_diff … lh rh〉.
     42
     43definition defined ≝
     44  λglobals: list ident.
     45  λs: joint_statement ERTL globals.
    846  match s with
    947  [ sequential seq l ⇒
    1048    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 
    18 definition register_lattice ≝ (set register) × (set Register).
    19 definition lattice_property ≝ register_lattice.
    20 definition lattice_bottom: register_lattice ≝ 〈set_empty register, set_empty Register〉.
    21 definition lattice_psingleton: register → register_lattice ≝
    22   λr.
    23     〈set_singleton … r, set_empty …〉.
    24 definition lattice_hsingleton: Register → register_lattice ≝
    25   λr.
    26     〈set_empty …, set_singleton … r〉.
    27 
    28 definition lattice_join: register_lattice → register_lattice → register_lattice ≝
    29   λleft.
    30   λright.
    31   let 〈lp, lh〉 ≝ left in
    32   let 〈rp, rh〉 ≝ right in
    33     〈set_union … lp rp, set_union … lh rh〉.
    34 
    35 definition lattice_diff: register_lattice → register_lattice → register_lattice ≝
    36   λleft.
    37   λright.
    38   let 〈lp, lh〉 ≝ left in
    39   let 〈rp, rh〉 ≝ right in
    40     〈set_diff … lp rp, set_diff … lh rh〉.
    41 
    42 definition lattice_equal: register_lattice → register_lattice → bool ≝
    43   λleft.
    44   λright.
    45   let 〈lp, lh〉 ≝ left in
    46   let 〈rp, rh〉 ≝ right in
    47     andb (set_equal … (eq_identifier …) lp rp) (set_equal … eq_Register lh rh).
    48 
    49 definition lattice_is_maximal: register_lattice → bool ≝ λl. false.
    50 
    51 record lattice_property_sig: Type[1] ≝
    52 {
    53   lp_type      : Type[0];
    54   lp_property  : Type[0];
    55   lp_bottom    : lp_type;
    56   lp_psingleton: register → lp_type;
    57   lp_hsingleton: Register → lp_type;
    58   lp_join      : lp_type → lp_type → lp_type;
    59   lp_diff      : lp_type → lp_type → lp_type;
    60   lp_equal     : lp_type → lp_type → bool;
    61   lp_is_maximal: lp_type → bool
    62 }.
    63 
    64 definition property ≝
    65   mk_lattice_property_sig
    66     ((set register) × (set Register))
    67     lattice_property
    68     lattice_bottom
    69     lattice_psingleton
    70     lattice_hsingleton
    71     lattice_join
    72     lattice_diff
    73     lattice_equal
    74     lattice_is_maximal.
    75 
    76 definition defined ≝
    77   λglobals: list ident.
    78   λs: ertl_statement globals.
     49    [ step_seq s ⇒
     50      match s with
     51      [ OP2 op2 r1 r2 _ ⇒
     52        match op2 with
     53        [ Add ⇒ rl_join (rl_hsingleton RegisterCarry) (rl_psingleton r1)
     54        | Addc ⇒ rl_join (rl_hsingleton RegisterCarry) (rl_psingleton r1)
     55        | Sub ⇒ rl_join (rl_hsingleton RegisterCarry)  (rl_psingleton r1)
     56        | _ ⇒ rl_psingleton r1
     57        ]
     58      | CLEAR_CARRY ⇒ rl_hsingleton RegisterCarry
     59      | SET_CARRY ⇒ rl_hsingleton RegisterCarry
     60      | OPACCS opaccs dr1 dr2 sr1 sr2 ⇒
     61        rl_join (rl_join (rl_psingleton dr1)
     62                                    (rl_psingleton dr2))
     63                      (rl_hsingleton RegisterCarry)
     64      | OP1 op1 r1 r2 ⇒ rl_join (rl_psingleton r1) (rl_psingleton r2)
     65      | POP r ⇒ rl_psingleton r
     66      | ADDRESS _ _ r1 r2 ⇒ rl_join (rl_psingleton r1) (rl_psingleton r2)
     67      | LOAD r _ _ ⇒ rl_psingleton r
     68      | COMMENT c ⇒ rl_bottom
     69      | STORE acc_a dpl dph ⇒ rl_bottom
     70      | COST_LABEL clabel ⇒ rl_bottom
     71      | PUSH r ⇒ rl_bottom
     72      | MOVE pair_reg ⇒
     73        (* first register relevant only *)
     74        match \fst pair_reg with
     75        [ PSD p ⇒ rl_psingleton p
     76        | HDW h ⇒ rl_hsingleton h
     77        ]
     78      | extension_seq ext ⇒
     79        match ext with
     80        [ ertl_new_frame ⇒ rl_join (rl_hsingleton RegisterSPL) (rl_hsingleton RegisterSPH)
     81        | ertl_del_frame ⇒ rl_join (rl_hsingleton RegisterSPL) (rl_hsingleton RegisterSPH)
     82        | ertl_frame_size r ⇒ rl_psingleton r
     83        ]
     84      (* Potentially destroys all caller-save hardware registers. *)
     85      | CALL_ID id _ _ ⇒ 〈set_empty …, set_from_list … RegisterCallerSaved〉
     86      | extension_call abs ⇒ match abs in void with [ ]
     87      ]
     88    | COND r lbl_true ⇒ rl_bottom
     89    ]
     90  | final _ ⇒ rl_bottom
     91  ].
     92
     93definition ret_regs ≝ set_from_list … RegisterRets.
     94
     95definition rl_arg : psd_argument → register_lattice ≝
     96  λarg.match arg with
     97  [ Imm _ ⇒ rl_bottom
     98  | Reg r ⇒ rl_psingleton r
     99  ].
     100
     101definition used ≝
     102  λglobals: list ident.
     103  λs: joint_statement ERTL globals.
    79104  match s with
    80105  [ sequential seq l ⇒
    81106    match seq with
    82     [ OP2 op2 r1 r2 _ ⇒
    83       match op2 with
    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
     107    [ step_seq s ⇒
     108      match s with
     109      [ OP2 op2 acc_a r1 r2 ⇒
     110        rl_join (rl_join (rl_arg r1) (rl_arg r2))
     111          (match op2 with
     112            [ Addc ⇒ rl_hsingleton RegisterCarry
     113            | Sub ⇒ rl_hsingleton RegisterCarry
     114            | _ ⇒ rl_bottom
     115            ])
     116      (* acc_a and acc_b *)
     117      | OPACCS opaccs dr1 dr2 sr1 sr2 ⇒
     118        rl_join (rl_arg sr1) (rl_arg sr2)
     119      | OP1 op1 r1 r2 ⇒ rl_psingleton r2
     120      | LOAD acc_a dpl dph ⇒ rl_join (rl_arg dpl) (rl_arg dph)
     121      | STORE acc_a dpl dph ⇒
     122        rl_join (rl_join (rl_arg acc_a) (rl_arg dpl)) (rl_arg dph)
     123      | PUSH r ⇒ rl_arg r
     124      | MOVE pair_reg ⇒
     125        let r2 ≝ \snd pair_reg in
     126        match r2 with
     127        [ Reg p ⇒
     128          match p with
     129          [ PSD r ⇒ rl_psingleton r
     130          | HDW r ⇒ rl_hsingleton r
     131          ]
     132        | Imm _ ⇒ rl_bottom
     133        ]
     134      | extension_seq ext ⇒
     135        match ext with
     136        [ ertl_new_frame ⇒ rl_join (rl_hsingleton RegisterSPL) (rl_hsingleton RegisterSPH)
     137        | ertl_del_frame ⇒ rl_join (rl_hsingleton RegisterSPL) (rl_hsingleton RegisterSPH)
     138        | ertl_frame_size r ⇒ rl_bottom
     139        ]
     140      (* Reads the hardware registers that are used to pass parameters. *)
     141      | CALL_ID _ nparams _ ⇒ 〈set_empty …, set_from_list … (prefix ? nparams RegisterParams)〉
     142      | extension_call abs ⇒ match abs in void with [ ]
     143      | _ ⇒ rl_bottom
    88144      ]
    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
    98     (* Potentially destroys all caller-save hardware registers. *)
    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 ⇒
    106       (* first register relevant only *)
    107       let r1 ≝ \fst pair_reg in
    108       match r1 with
    109       [ pseudo p ⇒ lattice_psingleton p
    110       | hardware h ⇒ lattice_hsingleton h
    111       ]
    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 
    121 definition ret_regs ≝ set_from_list … RegisterRets.
    122 
    123 definition used ≝
    124   λglobals: list ident.
    125   λs: ertl_statement globals.
     145    | COND r lbl_true ⇒ rl_psingleton r
     146    ]
     147  | final fin ⇒
     148    match fin with
     149    [ RETURN ⇒ 〈set_empty …, set_union … (set_from_list … RegisterCalleeSaved) ret_regs〉
     150    | GOTO l ⇒ rl_bottom
     151    | tailcall abs ⇒ match abs in void with [ ]
     152    ]
     153  ].
     154
     155definition eliminable ≝
     156  λglobals: list ident.
     157  λl: register_lattice.
     158  λs: joint_statement ERTL globals.
     159  let pliveafter ≝ \fst l in
     160  let hliveafter ≝ \snd l in
    126161  match s with
    127162  [ sequential seq l ⇒
    128163    match seq with
    129     [ OP2 op2 acc_a r1 r2 ⇒
    130       match op2 with
    131       [ Addc ⇒
    132         lattice_join (lattice_join (lattice_psingleton r1) (lattice_psingleton r2)) (lattice_hsingleton RegisterCarry)
    133       | _ ⇒ lattice_join (lattice_psingleton r1) (lattice_psingleton r2)
     164    [ step_seq s ⇒
     165      match s with
     166      [ OP2 op2 r1 r2 r3 ⇒
     167        if match op2 with
     168          [ Add ⇒ set_member … eq_Register RegisterCarry hliveafter
     169          | Addc ⇒ set_member … eq_Register RegisterCarry hliveafter
     170          | Sub ⇒ set_member … eq_Register RegisterCarry hliveafter
     171          | _ ⇒ false
     172          ] ∨ set_member … (eq_identifier …) r1 pliveafter
     173        then
     174          None ?
     175        else
     176          Some ? l
     177      | OPACCS opaccs dr1 dr2 sr1 sr2 ⇒
     178        if set_member … (eq_identifier …) dr1 pliveafter ∨
     179           set_member … (eq_identifier …) dr2 pliveafter ∨
     180           set_member … eq_Register RegisterCarry hliveafter then
     181          None ?
     182        else
     183          Some ? l
     184      | OP1 op1 r1 r2 ⇒
     185        if set_member … (eq_identifier …) r1 pliveafter then
     186          None ?
     187        else
     188          Some ? l
     189      | ADDRESS _ _ r1 r2 ⇒
     190        if set_member … (eq_identifier …) r1 pliveafter ∨
     191           set_member … (eq_identifier …) r2 pliveafter then
     192          None ?
     193        else
     194          Some ? l
     195      | LOAD acc_a dpl dph ⇒
     196        if set_member ? (eq_identifier …) acc_a pliveafter then
     197          None ?
     198        else
     199          Some ? l
     200      | MOVE pair_reg ⇒
     201        if match \fst pair_reg with
     202          [ PSD p1 ⇒
     203            set_member … (eq_identifier …) p1 pliveafter
     204          | HDW h1 ⇒
     205            set_member … eq_Register h1 hliveafter
     206          ] then
     207            None ?
     208          else
     209            Some ? l
     210      | extension_seq ext ⇒
     211        match ext with
     212        [ ertl_new_frame ⇒ None ?
     213        | ertl_del_frame ⇒ None ?
     214        | ertl_frame_size r ⇒
     215          if set_member ? (eq_identifier RegisterTag) r pliveafter then
     216            None ?
     217          else
     218            Some ? l
     219        ]
     220      | _ ⇒ None ?
    134221      ]
    135     | CLEAR_CARRY ⇒ lattice_bottom
    136     | SET_CARRY ⇒ lattice_bottom
    137     (* acc_a and acc_b *)
    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)
    145     (* Reads the hardware registers that are used to pass parameters. *)
    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 ⇒
    150       lattice_join (lattice_join (lattice_psingleton acc_a) (lattice_psingleton dpl)) (lattice_psingleton dph)
    151     | COST_LABEL clabel ⇒ lattice_bottom
    152     | PUSH r ⇒ lattice_psingleton r
    153     | MOVE pair_reg ⇒
    154       let r2 ≝ \snd pair_reg in
    155       match r2 with
    156       [ pseudo p ⇒ lattice_psingleton p
    157       | hardware h ⇒ lattice_hsingleton h
    158       ]
    159   | extension ext ⇒
    160     match ext with
    161     [ ertl_st_ext_new_frame ⇒ lattice_join (lattice_hsingleton RegisterSPL) (lattice_hsingleton RegisterSPH)
    162     | ertl_st_ext_del_frame ⇒ lattice_join (lattice_hsingleton RegisterSPL) (lattice_hsingleton RegisterSPH)
    163     | ertl_st_ext_frame_size r ⇒ lattice_bottom]]
    164   | RETURN ⇒ 〈set_empty …, set_union … (set_from_list … RegisterCalleeSaved) ret_regs〉
    165   | GOTO l ⇒ lattice_bottom
    166   ].
    167 
    168 definition eliminable ≝
    169   λglobals: list ident.
    170   λl: register_lattice.
    171   λs: ertl_statement globals.
    172   let 〈pliveafter, hliveafter〉 ≝ l in
    173   match s with
    174   [ sequential seq l ⇒
    175     match seq with
    176     [ OP2 op2 r1 r2 r3 ⇒
    177       if set_member … (eq_identifier …) r1 pliveafter ∨
    178          set_member … eq_Register RegisterCarry hliveafter then
    179         None ?
    180       else
    181         Some ? l
    182     | CLEAR_CARRY ⇒ None ?
    183     | SET_CARRY ⇒ None ?
    184     | OPACCS opaccs dr1 dr2 sr1 sr2 ⇒
    185       if set_member … (eq_identifier …) dr1 pliveafter ∨
    186          set_member … (eq_identifier …) dr2 pliveafter ∨
    187          set_member … eq_Register RegisterCarry hliveafter then
    188         None ?
    189       else
    190         Some ? l
    191     | OP1 op1 r1 r2 ⇒
    192       if set_member … (eq_identifier …) r1 pliveafter ∨
    193          set_member … eq_Register RegisterCarry hliveafter then
    194         None ?
    195       else
    196         Some ? l
    197     | POP r ⇒ None ?
    198     | INT r _ ⇒
    199       if set_member … (eq_identifier …) r pliveafter ∨
    200          set_member … eq_Register RegisterCarry hliveafter then
    201         None ?
    202       else
    203         Some ? l
    204     | ADDRESS _ _ r1 r2 ⇒
    205       if set_member … (eq_identifier …) r1 pliveafter ∨
    206          set_member … (eq_identifier …) r2 pliveafter ∨
    207          set_member … eq_Register RegisterCarry hliveafter then
    208         None ?
    209       else
    210         Some ? l
    211     | LOAD acc_a dpl dph ⇒
    212       if set_member ? (eq_identifier …) acc_a pliveafter ∨
    213          set_member … eq_Register RegisterCarry hliveafter then
    214         None ?
    215       else
    216         Some ? l
    217     | CALL_ID _ nparams _ ⇒ None ?
    218     | COMMENT c ⇒ None ?
    219     | COND r lbl_true ⇒ None ?
    220     | STORE acc_a dpl dph ⇒ None ?
    221     | COST_LABEL clabel ⇒ None ?
    222     | PUSH r ⇒ None ?
    223     | MOVE pair_reg ⇒
    224       let r1 ≝ \fst pair_reg in
    225       let r2 ≝ \snd pair_reg in
    226       match r1 with
    227       [ pseudo p1 ⇒
    228         if set_member … (eq_identifier …) p1 pliveafter ∨
    229            set_member … eq_Register RegisterCarry hliveafter then
    230           None ?
    231         else
    232           Some ? l
    233       | hardware h1 ⇒
    234         if set_member … eq_Register h1 hliveafter then
    235           None ?
    236         else
    237           Some ? l]
    238     | extension ext ⇒
    239       match ext with
    240       [ ertl_st_ext_new_frame ⇒ None ?
    241       | ertl_st_ext_del_frame ⇒ None ?
    242       | ertl_st_ext_frame_size r ⇒
    243         if set_member ? (eq_identifier RegisterTag) r pliveafter ∨
    244            set_member ? eq_Register RegisterCarry hliveafter then
    245           None ?
    246         else
    247           Some ? l]]
    248   | GOTO l ⇒ None ?
    249   | RETURN ⇒ None ?
    250   ].
    251 
    252 definition statement_semantics: ∀globals: list ident. ertl_statement globals → register_lattice → register_lattice ≝
     222    | COND _ _ ⇒ None ?
     223    ]
     224  | _ ⇒ None ?
     225  ].
     226
     227definition statement_semantics: ∀globals: list ident.
     228  joint_statement ERTL globals → register_lattice → register_lattice ≝
    253229  λglobals.
    254230  λstmt.
    255231  λliveafter.
    256232  match eliminable globals liveafter stmt with
    257   [ None ⇒ lattice_join (lattice_diff liveafter (defined globals stmt)) (used globals stmt)
     233  [ None ⇒ rl_join (rl_diff liveafter (defined globals stmt)) (used globals stmt)
    258234  | Some l ⇒ liveafter
    259235  ].
    260236
    261 definition valuation ≝ label → register_lattice.
    262 definition rhs ≝ valuation → lattice_property.
    263 definition equations ≝ label → rhs.
    264 
    265237definition livebefore ≝
    266238  λglobals: list ident.
    267   λint_fun: ertl_internal_function globals.
     239  λint_fun: joint_internal_function ERTL globals.
    268240  λlabel.
    269   λliveafter: valuation.
    270   match lookup (joint_if_code … int_fun) label with
    271   [ None      ⇒ ?
     241  λliveafter: valuation register_lattice.
     242  match lookup ?? (joint_if_code … int_fun) label with
     243  [ None      ⇒ rl_bottom
    272244  | Some stmt ⇒ statement_semantics globals stmt (liveafter label)
    273245  ].
    274   cases not_implemented (* XXX *)
    275 qed.
    276246
    277247definition liveafter ≝
    278   λglobals: list ident.
    279   λint_fun: ertl_internal_function globals.
     248   λglobals: list ident.
     249  λint_fun: joint_internal_function ERTL globals.
    280250  λlabel.
    281   λliveafter: valuation.
    282   match lookup … (joint_if_code … int_fun) label with
    283   [ None      ⇒ ?
    284   | Some stmt ⇒ set_fold ? ? (λsuccessor. λaccu: register_lattice.
    285       lattice_join (livebefore globals int_fun successor liveafter) accu)
    286       (statement_successors globals stmt) lattice_bottom
    287   ].
    288   cases not_implemented (* XXX *)
    289 qed.
    290 
    291 record fixpoint: Type[0] ≝
    292 {
    293   (* XXX: this never fails to compute a fixed point as in any program we will
    294           only ever use a finite number of pseudoregisters, therefore no chain
    295           conditions, etc. are necessary for this to terminate with a correct
    296           solution. *)
    297   fix_lfp    :1> equations → valuation;
    298   fix_correct:
    299     ∀globals: list ident.
    300 (*    ∀int_fun.*)
    301     ∀f. (* CSC: was let f ≝ liveafter globals int_fun in *)
    302       ∀v: label.
    303         lattice_equal (f v (fix_lfp f)) (fix_lfp f v) (*CSC: TOO STRONG: WE ONLY NEED CORRECTNESS NOT COMPLETENESS *)
    304 }.
    305 
    306 axiom the_fixpoint: fixpoint.
    307 
    308 definition analyse ≝
     251  λliveafter: valuation register_lattice.
     252 match lookup ?? (joint_if_code … int_fun) label with
     253  [ None      ⇒ rl_bottom
     254  | Some stmt ⇒
     255    \fold[rl_join,rl_bottom]_{successor ∈ stmt_labels … stmt}
     256      (livebefore globals int_fun successor liveafter)
     257  ].
     258
     259definition analyse_liveness ≝
    309260  λglobals.
    310261  λint_fun.
    311     the_fixpoint (liveafter globals int_fun).
     262    the_fixpoint ? (liveafter globals int_fun).
     263
     264definition vertex ≝ register + Register.
     265
     266definition plives : register → register_lattice → bool ≝
     267  λvertex.λprop.set_member ? (eq_identifier RegisterTag) vertex (\fst prop).
     268definition hlives : Register → register_lattice → bool ≝
     269  λvertex.λprop.set_member ? eq_Register vertex (\snd prop).
     270
     271definition lives : vertex → register_lattice → bool ≝
     272  λvertex.
     273  match vertex with
     274  [ inl v ⇒ plives v
     275  | inr v ⇒ hlives v
     276  ].
  • src/ERTL/semantics.ma

    r2041 r2286  
    33include alias "common/Identifiers.ma".
    44
     5record ertl_psd_env : Type[0] ≝
     6  { psd_regs : register_env beval
     7  (* this tells what pseudo-registers should have their value corrected by spilled_no *)
     8  ; need_spilled_no : identifier_set RegisterTag
     9  }.
     10
     11definition set_psd_regs ≝ λx,env.mk_ertl_psd_env x (need_spilled_no env).
     12definition add_need_spilled_no ≝
     13  λr,env.mk_ertl_psd_env (psd_regs env) (add_set … (need_spilled_no env) r).
     14definition rm_need_spilled_no ≝
     15  λr,env.mk_ertl_psd_env (psd_regs env) (need_spilled_no env ∖  {(r)}).
     16
     17definition ertl_reg_env ≝ ertl_psd_env × hw_register_env.
     18
    519definition ps_reg_store ≝
    6  λr,v.λlocal_env:(register_env beval) × hw_register_env.
    7   do res ← reg_store r v (\fst local_env) ;
    8   OK … 〈res, \snd local_env〉.
     20 λr,v.λlocal_env : ertl_reg_env.
     21  do res ← reg_store r v (psd_regs (\fst local_env)) ;
     22  let psd_env ≝ set_psd_regs res (\fst local_env) in
     23  OK … 〈rm_need_spilled_no r psd_env, \snd local_env〉.
    924
    1025definition ps_reg_retrieve ≝
    11  λlocal_env:(register_env beval) × hw_register_env. reg_retrieve … (\fst local_env).
     26 λlocal_env:ertl_reg_env. reg_retrieve … (psd_regs (\fst local_env)).
    1227
    1328definition hw_reg_store ≝
    14  λr,v.λlocal_env:(register_env beval) × hw_register_env.
     29 λr,v.λlocal_env:ertl_reg_env.
    1530  OK … 〈\fst local_env,hwreg_store r v (\snd local_env)〉.
    1631
    1732definition hw_reg_retrieve ≝
    18  λlocal_env:(register_env beval) × hw_register_env.λreg.
     33 λlocal_env:ertl_reg_env.λreg.
    1934  OK … (hwreg_retrieve … (\snd local_env) reg).
    2035
    21 definition ertl_more_sem_params: more_sem_params ertl_params_ :=
    22  mk_more_sem_params ertl_params_
    23   (list (register_env beval)) [] ((register_env beval) × hw_register_env)
    24    (λsp.〈empty_map …,init_hw_register_env sp〉) 0 it
    25    ps_reg_store ps_reg_retrieve ps_reg_store ps_reg_retrieve ps_reg_store ps_reg_retrieve
    26     ps_reg_store ps_reg_retrieve ps_reg_store ps_reg_retrieve
    27      (λlocals,dest_src.
    28        do v ←
    29         match \snd dest_src with
    30         [ pseudo reg ⇒ ps_reg_retrieve locals reg
    31         | hardware reg ⇒ hw_reg_retrieve locals reg] ;
    32        match \fst dest_src with
    33        [ pseudo reg ⇒ ps_reg_store reg v locals
    34        | hardware reg ⇒ hw_reg_store reg v locals]).
    35 definition ertl_sem_params: sem_params ≝ mk_sem_params … ertl_more_sem_params.
     36definition ps_arg_retrieve ≝
     37  λlocal_env,a.
     38  match a with
     39  [ Reg r ⇒ ps_reg_retrieve local_env r
     40  | Imm b ⇒ return b
     41  ].
    3642
    37 definition ertl_init_locals :
    38  list register →
    39   (register_env beval) × hw_register_env → (register_env beval) × hw_register_env ≝
    40  λlocals,lenv.
    41   〈foldl … (λlenv,reg. add … lenv reg BVundef) (empty_map …) locals, \snd lenv〉.
     43definition ERTL_state : sem_state_params ≝
     44  mk_sem_state_params
     45 (* framesT ≝ *) (list ertl_psd_env)
     46 (* empty_framesT ≝ *) [ ]
     47 (* regsT ≝ *) ertl_reg_env
     48 (* empty_regsT ≝ *) (λsp.〈mk_ertl_psd_env (empty_map …) ∅,init_hw_register_env sp〉).
    4249
    43 (*CSC: could we use here a dependent type to avoid the Error case? *)
    44 axiom EmptyStack: String.
    45 definition ertl_pop_frame:
    46  ∀globals. genv … (ertl_params globals) → state … ertl_sem_params → res (state … ertl_sem_params) ≝
    47  λglobals,ge,st.
    48   let frms ≝ st_frms ? st in
    49   match frms with
    50   [ nil ⇒ Error ? [MSG EmptyStack]
    51   | cons hd tl ⇒
    52      OK … (set_frms ertl_sem_params tl (set_regs ertl_sem_params 〈hd, \snd (regs … st)〉 st)) ].
     50(* we ignore need_spilled_no as we never move framesize based values around in the
     51   translation *)
     52definition ertl_eval_move ≝ λenv,pr.
     53      ! v ←
     54        match \snd pr with
     55        [ Reg src ⇒
     56          match src with
     57          [ PSD r ⇒ ps_reg_retrieve env r
     58          | HDW r ⇒ hw_reg_retrieve env r
     59          ]
     60        | Imm bv ⇒ return bv ] ;
     61      match \fst pr with
     62      [ PSD r ⇒ ps_reg_store r v env
     63      | HDW r ⇒ hw_reg_store r v env
     64      ].
     65
     66definition ertl_allocate_local ≝
     67  λreg.λlenv : ertl_reg_env.
     68  〈set_psd_regs (add … (psd_regs (\fst lenv)) reg BVundef) (\fst lenv), \snd lenv〉.
    5369
    5470definition ertl_save_frame:
    55  address → nat → nat → nat → unit → state … ertl_sem_params → res (state … ertl_sem_params) ≝
    56  λl.λ_.λ_.λ_.λ_.λst.
    57   do st ← save_ra … st l ;
     71 cpointer → unit → state … ERTL_state → res (state … ERTL_state) ≝
     72 λpc.λ_.λst.
     73  do st ← save_ra … st pc ;
    5874  OK …
    59    (set_frms ertl_sem_params (\fst (regs … st) :: (st_frms … st))
    60     (set_regs ertl_sem_params 〈empty_map …,\snd (regs … st)〉 st)).
    61 
    62 definition ertl_result_regs:
    63  ∀globals. genv … (ertl_params globals) → state ertl_sem_params → res (list register) ≝
    64  λglobals,ge,st.
    65   do fn ← graph_fetch_function … globals ge st ;
    66   OK … (joint_if_result … fn).
     75   (set_frms ERTL_state (\fst (regs ERTL_state st) :: (st_frms … st))
     76    (set_regs ERTL_state 〈mk_ertl_psd_env (empty_map …) ∅,\snd (regs … st)〉 st)).
    6777
    6878(*CSC: XXXX, for external functions only*)
    69 axiom ertl_fetch_external_args: external_function → state ertl_sem_params → res (list val).
    70 axiom ertl_set_result: list val → state ertl_sem_params → res (state ertl_sem_params).
     79axiom ertl_fetch_external_args: external_function → state ERTL_state → res (list val).
     80axiom ertl_set_result : list val → unit → state ERTL_state → res (state ERTL_state).
     81(* I think there should be a list beval in place of list val here
     82  λvals.λ_.λst.
     83  (* set all RegisterRets to 0 *)
     84  let reset ≝ λenv,r.hwreg_store r (BVByte (bv_zero …)) env in
     85  let env ≝ foldl … reset (\snd (regs … st)) RegisterRets in
     86  let set_vals ≝ λenv,pr.hwreg_store (\fst pr) (\snd pr) env in ?.
     87  let env' ≝ foldl … set_vals env (zip_pottier … RegisterRets vals) in
     88  return (set_regs ERTL_state 〈\fst (regs … st), env'〉 st).*)
    7189
    72 definition framesize:
    73  ∀globals. genv … (ertl_params globals) → state ertl_sem_params → res nat ≝
    74   λglobals,ge,st.
    75    do f ← graph_fetch_function … ge st ;
    76    OK ? (joint_if_stacksize globals … f).
     90definition xdata_pointer_of_address: address → res xpointer ≝
     91λp.let 〈v1,v2〉 ≝ p in
     92! p ← pointer_of_bevals [v1;v2] ;
     93match ptype p return λpty. ptype p = pty → res (Σp:pointer. ptype p = XData) with
     94[ XData ⇒ λE.OK ? (mk_Sig … p E)
     95| _ ⇒ λ_.Error … [MSG BadPointer]
     96] (refl …).
    7797
    78 definition get_hwsp : state ertl_sem_params → address ≝
     98definition address_of_xdata_pointer: xpointer → address ≝
     99λp.list_to_pair … (bevals_of_pointer p) ?. % qed.
     100
     101definition get_hwsp : ERTL_state → res xpointer ≝
    79102 λst.
    80103  let spl ≝ hwreg_retrieve (\snd (regs … st)) RegisterSPL in
    81104  let sph ≝ hwreg_retrieve (\snd (regs … st)) RegisterSPH in
    82   〈spl,sph〉.
     105  xdata_pointer_of_address 〈spl,sph〉.
    83106
    84 definition set_hwsp : address → state ertl_sem_params → state ertl_sem_params
     107definition set_hwsp : xpointer → ERTL_state → ERTL_state
    85108 λsp,st.
    86   let 〈spl,sph〉 ≝ sp in
     109  let 〈spl,sph〉 ≝ address_of_xdata_pointer sp in
    87110  let hwregs ≝ hwreg_store RegisterSPL spl (\snd (regs … st)) in
    88111  let hwregs ≝ hwreg_store RegisterSPH sph hwregs in
    89   set_regs ertl_sem_params 〈\fst (regs … st),hwregs〉 st.
     112  set_regs ERTL_state 〈\fst (regs … st),hwregs〉 st.
    90113
    91 definition ertl_more_sem_params1: ∀globals. more_sem_params1 … (ertl_params globals) ≝
    92  λglobals.
    93   mk_more_sem_params1 … ertl_more_sem_params graph_succ_p (graph_pointer_of_label …)
    94     (graph_fetch_statement …) (load_ra …) (ertl_result_regs …)
    95     ertl_init_locals ertl_save_frame (ertl_pop_frame …)
    96     ertl_fetch_external_args ertl_set_result.
    97 definition ertl_sem_params1: ∀globals. sem_params1 globals ≝
    98  λglobals. mk_sem_params1 … (ertl_more_sem_params1 globals).
     114definition eval_ertl_seq:
     115 ∀globals. genv ERTL globals →
     116  ertl_seq → joint_internal_function ERTL globals → ERTL_state →
     117   IO io_out io_in ERTL_state ≝
     118 λglobals,ge,stm,curr_fn,st.
     119 let framesize : Byte ≝ bitvector_of_nat 8 (joint_if_stacksize … curr_fn) in
     120  match stm with
     121   [ ertl_new_frame ⇒
     122      ! sp ← get_hwsp st ;
     123      let newsp ≝ shift_pointer … sp framesize in
     124      return set_hwsp newsp st
     125   | ertl_del_frame ⇒
     126      ! sp ← get_hwsp st ;
     127      let newsp ≝ shift_pointer … sp framesize in
     128      return set_hwsp newsp st
     129   | ertl_frame_size dst ⇒
     130      let env ≝ regs … st in
     131      ! env' ← ps_reg_store dst (BVByte framesize) env ;
     132      let env'' ≝ 〈add_need_spilled_no dst (\fst env'), \snd env'〉 in
     133      return set_regs ERTL_state env'' st
     134   ]. @hide_prf whd in match newsp; cases sp #ptr #EQ <EQ % qed. 
    99135
    100 definition ertl_exec_extended:
    101  ∀globals. genv globals (ertl_params globals) →
    102   ertl_statement_extension → label → state ertl_sem_params →
    103    IO io_out io_in (trace × (state ertl_sem_params)) ≝
    104  λglobals,ge,stm,l,st.
    105   match stm with
    106    [ ertl_st_ext_new_frame ⇒
    107       ! v ← framesize globals … ge st;
    108       let sp ≝ get_hwsp st in
    109       ! newsp ← addr_sub sp v;
    110       let st ≝ set_hwsp newsp st in
    111       ! st ← next … (ertl_sem_params1 globals) l st ;
    112         return 〈E0,st〉
    113    | ertl_st_ext_del_frame ⇒
    114       ! v ← framesize … ge st;
    115       let sp ≝ get_hwsp st in
    116       ! newsp ← addr_add sp v;
    117       let st ≝ set_hwsp newsp st in
    118       ! st ← next … (ertl_sem_params1 …) l st ;
    119         return 〈E0,st〉
    120    | ertl_st_ext_frame_size dst ⇒
    121       ! v ← framesize … ge st;
    122       ! st ← greg_store ertl_sem_params dst (BVByte (bitvector_of_nat … v)) st;
    123       ! st ← next … (ertl_sem_params1 …) l st ;
    124         return 〈E0, st〉
    125    ].
     136definition ertl_post_op2 ≝
     137  λop,dst,arg1,arg2,st.
     138  let local_env ≝ regs ERTL_state st in
     139  let f ≝ λarg,st.match arg with
     140     [ Reg r ⇒
     141       if r ∈ need_spilled_no (\fst local_env) then
     142         set_regs ERTL_state 〈add_need_spilled_no dst (\fst local_env),\snd local_env〉 st
     143       else
     144         st
     145     | _ ⇒ st
     146     ] in
     147  match op with
     148  [ Add ⇒ f arg1 (f arg2 st) (* won't happen both *)
     149  | Addc ⇒ f arg1 (f arg2 st) (* we have to think about what should we do with carry bit *)
     150  | Sub ⇒ f arg1 st
     151  | _ ⇒ st].
     152         
    126153
    127 definition ertl_more_sem_params2: ∀globals. more_sem_params2 … (ertl_params globals) ≝
    128  λglobals. mk_more_sem_params2 … (ertl_more_sem_params1 …) (ertl_exec_extended …).
    129 
    130 definition ertl_fullexec: fullexec io_out io_in ≝
    131  joint_fullexec … (λp. ertl_more_sem_params2 (prog_var_names … p)).
     154definition ERTL_semantics ≝
     155  make_sem_graph_params ERTL
     156  (mk_more_sem_unserialized_params ??
     157  (* st_pars            ≝ *) ERTL_state
     158  (* acca_store_        ≝ *) ps_reg_store
     159  (* acca_retrieve_     ≝ *) ps_reg_retrieve
     160  (* acca_arg_retrieve_ ≝ *) ps_arg_retrieve
     161  (* accb_store_        ≝ *) ps_reg_store
     162  (* accb_retrieve_     ≝ *) ps_reg_retrieve
     163  (* accb_arg_retrieve_ ≝ *) ps_arg_retrieve
     164  (* dpl_store_         ≝ *) ps_reg_store
     165  (* dpl_retrieve_      ≝ *) ps_reg_retrieve
     166  (* dpl_arg_retrieve_  ≝ *) ps_arg_retrieve
     167  (* dph_store_         ≝ *) ps_reg_store
     168  (* dph_retrieve_      ≝ *) ps_reg_retrieve
     169  (* dph_arg_retrieve_  ≝ *) ps_arg_retrieve
     170  (* snd_arg_retrieve_  ≝ *) ps_arg_retrieve
     171  (* pair_reg_move_     ≝ *) ertl_eval_move
     172  (* fetch_ra           ≝ *) (load_ra …)
     173  (* allocate_local     ≝ *) ertl_allocate_local
     174  (* save_frame         ≝ *) ertl_save_frame
     175  (* setup_call         ≝ *) (λ_.λ_.λ_.λst.return st)
     176  (* fetch_external_args≝ *) ertl_fetch_external_args
     177  (* set_result         ≝ *) ertl_set_result
     178  (* call_args_for_main ≝ *) 0
     179  (* call_dest_for_main ≝ *) it
     180  (* read_result        ≝ *) (λ_.λ_.λ_.
     181     λst.return map ?? (hwreg_retrieve (\snd (regs … st))) RegisterRets)
     182  (* eval_ext_seq       ≝ *) eval_ertl_seq
     183  (* eval_ext_tailcall  ≝ *) (λ_.λ_.λabs.match abs in void with [ ])
     184  (* eval_ext_call      ≝ *) (λ_.λ_.λabs.match abs in void with [ ])
     185  (* pop_frame          ≝ *) (λ_.λ_.λ_.λst.return st)
     186  (* post_op2           ≝ *) (λ_.λ_.ertl_post_op2)).
  • src/LIN/LIN.ma

    r1601 r2286  
    11include "LIN/joint_LTL_LIN.ma".
    2 include "basics/lists/list.ma".
    32
    4 definition lin_params_ : params_ ≝ mk_params_ ltl_lin_params__ unit.
     3definition LIN ≝ mk_lin_params LTL_LIN.
    54
    6 definition pre_lin_statement ≝ joint_statement lin_params_.
    7 definition lin_statement≝ λglobals.(option label) × (pre_lin_statement globals).
     5(* aid unification *)
     6unification hint 0 ≔
     7(*---------------*) ⊢
     8acc_a_reg LIN ≡ unit.
     9unification hint 0 ≔
     10(*---------------*) ⊢
     11acc_a_arg LIN ≡ unit.
     12unification hint 0 ≔
     13(*---------------*) ⊢
     14acc_b_reg LIN ≡ unit.
     15unification hint 0 ≔
     16(*---------------*) ⊢
     17acc_a_arg LIN ≡ unit.
     18unification hint 0 ≔
     19(*---------------*) ⊢
     20snd_arg LIN ≡ hdw_argument.
     21unification hint 0 ≔
     22(*---------------*) ⊢
     23ext_seq LIN ≡ ltl_lin_seq.
     24unification hint 0 ≔
     25(*---------------*) ⊢
     26pair_move LIN ≡ registers_move.
    827
    9 definition lin_params: ∀globals. params globals ≝
    10  λglobals.
    11   mk_params globals unit ltl_lin_params1 (list (lin_statement globals))
    12    (λcode. λl.
    13     find ?? (λs. let 〈l',x〉 ≝ s in
    14      match l' with [ None ⇒ None … | Some l'' ⇒ if eq_identifier … l l'' then Some … x else None ?]) code).
    15 
    16 definition lin_function ≝ λglobals. joint_function … (lin_params globals).
    17 definition lin_program ≝ joint_program lin_params.
     28definition lin_program ≝ joint_program LIN.
  • src/LIN/LINToASM.ma

    r1995 r2286  
    22include "utilities/BitVectorTrieSet.ma".
    33include "LIN/LIN.ma".
     4include "ASM/ASM.ma".
     5
     6definition register_address: Register → [[ acc_a; direct; registr ]] ≝
     7  λr: Register.
     8    match r with
     9    [ Register00 ⇒ REGISTER [[ false; false; false ]]
     10    | Register01 ⇒ REGISTER [[ false; false; true ]]
     11    | Register02 ⇒ REGISTER [[ false; true; false ]]
     12    | Register03 ⇒ REGISTER [[ false; true; true ]]
     13    | Register04 ⇒ REGISTER [[ true; false; false ]]
     14    | Register05 ⇒ REGISTER [[ true; false; true ]]
     15    | Register06 ⇒ REGISTER [[ true; true; false ]]
     16    | Register07 ⇒ REGISTER [[ true; true; true ]]
     17    | RegisterA ⇒ ACC_A
     18    | RegisterB ⇒ DIRECT (bitvector_of_nat 8 240)
     19    | RegisterDPL ⇒ DIRECT (bitvector_of_nat 8 82)
     20    | RegisterDPH ⇒ DIRECT (bitvector_of_nat 8 83)
     21    | _ ⇒ DIRECT (bitvector_of_nat 8 (nat_of_register r))
     22    ]. @I qed.
     23
     24(* TODO:
     25  this should translate back end immediates (which rely on beval) to ASM
     26  byte immediates. How should it work? surely needs arguments for instantiation
     27  of blocks. If it's too much a fuss, we can go back to byte immediates in the
     28  back end. *)
     29definition asm_byte_of_beval : beval → Byte ≝
     30  λb.match b with
     31    [ BVByte b ⇒ b
     32    | BVundef ⇒ (* any will do *) zero_byte
     33    | BVnonzero ⇒ (* any will do *) maximum 7 @@ [[ true ]]
     34    | BVnull _ ⇒ zero_byte (* is it correct? *)
     35    | BVptr b p o ⇒ ?
     36    ].
     37  cases daemon qed.
     38
     39definition arg_address : hdw_argument → [[ acc_a ; direct ; registr ; data ]] ≝
     40  λa.match a with
     41  [ Reg r ⇒ register_address r
     42  | Imm bv ⇒ DATA (asm_byte_of_beval bv)
     43  ].
     44  cases a #x [2: normalize //] normalize nodelta
     45  elim (register_address ?) #rslt @is_in_subvector_is_in_supervector @I
     46qed.
    447
    548let rec association (i: ident) (l: list (ident × nat))
     
    2568qed.
    2669
     70definition lin_statement ≝ λg.labelled_obj LabelTag (joint_statement LIN g).
     71 
    2772definition statement_labels ≝
    2873  λg: list ident.
     
    3378    [ sequential instr' _ ⇒
    3479      match instr' with
    35       [ COST_LABEL lbl ⇒ { (toASM_ident ? lbl) }
     80      [ step_seq instr'' ⇒
     81        match instr'' with
     82        [ COST_LABEL lbl ⇒ { (toASM_ident ? lbl) }
     83        | _ ⇒ ∅
     84        ]
    3685      | COND acc_a_reg lbl ⇒ { (toASM_ident ? lbl) }
     86      ]
     87    | final instr' ⇒
     88      match instr' with
     89      [ GOTO lbl ⇒ {(toASM_ident ? lbl)}
    3790      | _ ⇒ ∅
    3891      ]
    39     | RETURN ⇒ ∅
    40     | GOTO lbl ⇒ {(toASM_ident ? lbl)} ]
     92    ]
    4193  in
    4294  match label with
     
    55107  λA: Type[0].
    56108  λglobals: list ident.
    57   λf: A × (lin_function globals).
     109  λf: A × (joint_function LIN globals).
    58110  let 〈ignore, fun_def〉 ≝ f in
    59111  match fun_def return λ_. identifier_set ? with
     
    67119  λglobals: list ident.
    68120  λlabels: identifier_set ?.
    69   λfunct: A × (lin_function globals).
     121  λfunct: A × (joint_function LIN globals).
    70122    labels ∪ (function_labels ? globals funct).
    71123
     
    80132definition accumulator_address ≝ DIRECT (bitvector_of_nat 8 224).
    81133
     134(* TODO: check and change to free bit *)
     135definition asm_other_bit ≝ BIT_ADDR (zero_byte).
     136
    82137definition translate_statements ≝
    83138  λglobals: list (ident × nat).
    84139  λglobals_old: list ident.
    85140  λprf: ∀i: ident. member i (eq_identifier ?) globals_old → member i (eq_identifier ?) (map ? ? (fst ? ?) globals).
    86   λstatement: pre_lin_statement globals_old.
     141  λstatement: joint_statement LIN globals_old.
    87142  match statement with
    88   [ GOTO lbl ⇒ Jmp (toASM_ident ? lbl)
    89   | RETURN ⇒ Instruction (RET ?)
     143  [ final instr ⇒
     144    match instr with
     145    [ GOTO lbl ⇒ Jmp (toASM_ident ? lbl)
     146    | RETURN ⇒ Instruction (RET ?)
     147    | tailcall abs ⇒ match abs in void with [ ]
     148    ]
    90149  | sequential instr _ ⇒
    91150      match instr with
    92       [ extension ext ⇒ ⊥
    93       | COMMENT comment ⇒ Comment comment
    94       | COST_LABEL lbl ⇒ Cost lbl
    95       | POP _ ⇒ Instruction (POP ? accumulator_address)
    96       | PUSH _ ⇒ Instruction (PUSH ? accumulator_address)
    97       | CLEAR_CARRY ⇒ Instruction (CLR ? CARRY)
    98       | CALL_ID f _ _ ⇒ Call (toASM_ident ? f)
    99       | OPACCS accs _ _ _ _ ⇒
    100         match accs with
    101         [ Mul ⇒ Instruction (MUL ? ACC_A ACC_B)
    102         | DivuModu ⇒ Instruction (DIV ? ACC_A ACC_B)
    103         ]
    104       | OP1 op1 _ _ ⇒
    105         match op1 with
    106         [ Cmpl ⇒ Instruction (CPL ? ACC_A)
    107         | Inc ⇒ Instruction (INC ? ACC_A)
    108         | Rl ⇒ Instruction (RL ? ACC_A)
    109         ]
    110       | OP2 op2 _ _ reg ⇒
    111         match op2 with
    112         [ Add ⇒
    113           let reg' ≝ register_address reg in
    114           match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
    115                                                          direct;
    116                                                          registr ]] x) → ? with
    117           [ ACC_A ⇒ λacc_a: True.
    118             Instruction (ADD ? ACC_A accumulator_address)
    119           | DIRECT d ⇒ λdirect1: True.
    120             Instruction (ADD ? ACC_A (DIRECT d))
    121           | REGISTER r ⇒ λregister1: True.
    122             Instruction (ADD ? ACC_A (REGISTER r))
    123           | _ ⇒ λother: False. ⊥
    124           ] (subaddressing_modein … reg')
    125         | Addc ⇒
    126           let reg' ≝ register_address reg in
    127           match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
    128                                                          direct;
    129                                                          registr ]] x) → ? with
    130           [ ACC_A ⇒ λacc_a: True.
    131             Instruction (ADDC ? ACC_A accumulator_address)
    132           | DIRECT d ⇒ λdirect2: True.
    133             Instruction (ADDC ? ACC_A (DIRECT d))
    134           | REGISTER r ⇒ λregister2: True.
    135             Instruction (ADDC ? ACC_A (REGISTER r))
    136           | _ ⇒ λother: False. ⊥
    137           ] (subaddressing_modein … reg')
    138         | Sub ⇒
    139           let reg' ≝ register_address reg in
    140           match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
    141                                                          direct;
    142                                                          registr ]] x) → ? with
    143           [ ACC_A ⇒ λacc_a: True.
    144             Instruction (SUBB ? ACC_A accumulator_address)
    145           | DIRECT d ⇒ λdirect3: True.
    146             Instruction (SUBB ? ACC_A (DIRECT d))
    147           | REGISTER r ⇒ λregister3: True.
    148             Instruction (SUBB ? ACC_A (REGISTER r))
    149           | _ ⇒ λother: False. ⊥
    150           ] (subaddressing_modein … reg')
    151         | And ⇒
    152           let reg' ≝ register_address reg in
    153           match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
    154                                                          direct;
    155                                                          registr ]] x) → ? with
    156           [ ACC_A ⇒ λacc_a: True.
    157             Instruction (NOP ?)
    158           | DIRECT d ⇒ λdirect4: True.
    159             Instruction (ANL ? (inl ? ? (inl ? ? 〈ACC_A, DIRECT d〉)))
    160           | REGISTER r ⇒ λregister4: True.
    161             Instruction (ANL ? (inl ? ? (inl ? ? 〈ACC_A, REGISTER r〉)))
    162           | _ ⇒ λother: False. ⊥
    163           ] (subaddressing_modein … reg')
    164         | Or ⇒
    165           let reg' ≝ register_address reg in
    166           match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
    167                                                          direct;
    168                                                          registr ]] x) → ? with
    169           [ ACC_A ⇒ λacc_a: True.
    170             Instruction (NOP ?)
    171           | DIRECT d ⇒ λdirect5: True.
    172             Instruction (ORL ? (inl ? ? (inl ? ? 〈ACC_A, DIRECT d〉)))
    173           | REGISTER r ⇒ λregister5: True.
    174             Instruction (ORL ? (inl ? ? (inl ? ? 〈ACC_A, REGISTER r〉)))
    175           | _ ⇒ λother: False. ⊥
    176           ] (subaddressing_modein … reg')
    177         | Xor ⇒
    178           let reg' ≝ register_address reg in
    179           match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
    180                                                          direct;
    181                                                          registr ]] x) → ? with
    182           [ ACC_A ⇒ λacc_a: True.
    183             Instruction (XRL ? (inr ? ? 〈accumulator_address, ACC_A〉))
    184           | DIRECT d ⇒ λdirect6: True.
    185             Instruction (XRL ? (inl ? ? 〈ACC_A, DIRECT d〉))
    186           | REGISTER r ⇒ λregister6: True.
    187             Instruction (XRL ? (inl ? ? 〈ACC_A, REGISTER r〉))
    188           | _ ⇒ λother: False. ⊥
    189           ] (subaddressing_modein … reg')
    190         ]
    191       | INT reg byte ⇒
    192         let reg' ≝ register_address reg in
    193           match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
    194                                                          direct;
    195                                                          registr ]] x) → ? with
    196           [ REGISTER r ⇒ λregister7: True.
    197             Instruction (MOV ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? (inr ? ? 〈REGISTER r, (data_of_int byte)〉))))))
    198           | ACC_A ⇒ λacc: True.
    199             Instruction (MOV ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? 〈ACC_A, (data_of_int byte)〉))))))
    200           | DIRECT d ⇒ λdirect7: True.
    201             Instruction (MOV ? (inl ? ? (inl ? ? (inl ? ? (inr ? ? 〈DIRECT d, (data_of_int byte)〉)))))
    202           | _ ⇒ λother: False. ⊥
    203           ] (subaddressing_modein … reg')
    204       | MOVE regs ⇒
    205          match regs with
    206           [ from_acc reg ⇒
     151      [ step_seq instr' ⇒
     152        match instr' with
     153        [ extension_seq ext ⇒
     154          match ext with
     155          [ SAVE_CARRY ⇒
     156            Instruction (MOV ? (inr ?? 〈asm_other_bit, CARRY〉))
     157          | RESTORE_CARRY ⇒
     158            Instruction (MOV ? (inl ?? (inr ?? 〈CARRY, asm_other_bit〉)))
     159          ]
     160        | COMMENT comment ⇒ Comment comment
     161        | COST_LABEL lbl ⇒ Cost lbl
     162        | POP _ ⇒ Instruction (POP ? accumulator_address)
     163        | PUSH _ ⇒ Instruction (PUSH ? accumulator_address)
     164        | CLEAR_CARRY ⇒ Instruction (CLR ? CARRY)
     165        | CALL_ID f _ _ ⇒ Call (toASM_ident ? f)
     166        | extension_call abs ⇒ match abs in void with [ ]
     167        | OPACCS accs _ _ _ _ ⇒
     168          match accs with
     169          [ Mul ⇒ Instruction (MUL ? ACC_A ACC_B)
     170          | DivuModu ⇒ Instruction (DIV ? ACC_A ACC_B)
     171          ]
     172        | OP1 op1 _ _ ⇒
     173          match op1 with
     174          [ Cmpl ⇒ Instruction (CPL ? ACC_A)
     175          | Inc ⇒ Instruction (INC ? ACC_A)
     176          | Rl ⇒ Instruction (RL ? ACC_A)
     177          ]
     178        | OP2 op2 _ _ reg ⇒
     179          match op2 with
     180          [ Add ⇒
     181            let reg' ≝ arg_address reg in
     182            match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
     183                                                           direct;
     184                                                           registr;
     185                                                           data ]] x) → ? with
     186            [ ACC_A ⇒ λacc_a: True.
     187              Instruction (ADD ? ACC_A accumulator_address)
     188            | DIRECT d ⇒ λdirect1: True.
     189              Instruction (ADD ? ACC_A (DIRECT d))
     190            | REGISTER r ⇒ λregister1: True.
     191              Instruction (ADD ? ACC_A (REGISTER r))
     192            | DATA b ⇒ λdata : True.
     193              Instruction (ADD ? ACC_A (DATA b))
     194            | _ ⇒ Ⓧ
     195            ] (subaddressing_modein … reg')
     196          | Addc ⇒
     197            let reg' ≝ arg_address reg in
     198            match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
     199                                                           direct;
     200                                                           registr;
     201                                                           data ]] x) → ? with
     202            [ ACC_A ⇒ λacc_a: True.
     203              Instruction (ADDC ? ACC_A accumulator_address)
     204            | DIRECT d ⇒ λdirect2: True.
     205              Instruction (ADDC ? ACC_A (DIRECT d))
     206            | REGISTER r ⇒ λregister2: True.
     207              Instruction (ADDC ? ACC_A (REGISTER r))
     208            | DATA b ⇒ λdata : True.
     209              Instruction (ADDC ? ACC_A (DATA b))
     210            | _ ⇒ Ⓧ
     211            ] (subaddressing_modein … reg')
     212          | Sub ⇒
     213            let reg' ≝ arg_address reg in
     214            match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
     215                                                           direct;
     216                                                           registr;
     217                                                           data ]] x) → ? with
     218            [ ACC_A ⇒ λacc_a: True.
     219              Instruction (SUBB ? ACC_A accumulator_address)
     220            | DIRECT d ⇒ λdirect3: True.
     221              Instruction (SUBB ? ACC_A (DIRECT d))
     222            | REGISTER r ⇒ λregister3: True.
     223              Instruction (SUBB ? ACC_A (REGISTER r))
     224            | DATA b ⇒ λdata : True.
     225              Instruction (SUBB ? ACC_A (DATA b))
     226            | _ ⇒ Ⓧ
     227            ] (subaddressing_modein … reg')
     228          | And ⇒
     229            let reg' ≝ arg_address reg in
     230            match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
     231                                                           direct;
     232                                                           registr;
     233                                                           data ]] x) → ? with
     234            [ ACC_A ⇒ λacc_a: True.
     235              Instruction (NOP ?)
     236            | DIRECT d ⇒ λdirect4: True.
     237              Instruction (ANL ? (inl ? ? (inl ? ? 〈ACC_A, DIRECT d〉)))
     238            | REGISTER r ⇒ λregister4: True.
     239              Instruction (ANL ? (inl ? ? (inl ? ? 〈ACC_A, REGISTER r〉)))
     240            | DATA b ⇒ λdata : True.
     241              Instruction (ANL ? (inl ? ? (inl ? ? 〈ACC_A, DATA b〉)))
     242            | _ ⇒ Ⓧ
     243            ] (subaddressing_modein … reg')
     244          | Or ⇒
     245            let reg' ≝ arg_address reg in
     246            match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
     247                                                           direct;
     248                                                           registr ; data ]] x) → ? with
     249            [ ACC_A ⇒ λacc_a: True.
     250              Instruction (NOP ?)
     251            | DIRECT d ⇒ λdirect5: True.
     252              Instruction (ORL ? (inl ? ? (inl ? ? 〈ACC_A, DIRECT d〉)))
     253            | REGISTER r ⇒ λregister5: True.
     254              Instruction (ORL ? (inl ? ? (inl ? ? 〈ACC_A, REGISTER r〉)))
     255            | DATA b ⇒ λdata : True.
     256              Instruction (ORL ? (inl ? ? (inl ? ? 〈ACC_A, DATA b〉)))
     257            | _ ⇒ Ⓧ
     258            ] (subaddressing_modein … reg')
     259          | Xor ⇒
     260            let reg' ≝ arg_address reg in
     261            match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
     262                                                           direct;
     263                                                           registr ; data ]] x) → ? with
     264            [ ACC_A ⇒ λacc_a: True.
     265              Instruction (XRL ? (inr ? ? 〈accumulator_address, ACC_A〉))
     266            | DIRECT d ⇒ λdirect6: True.
     267              Instruction (XRL ? (inl ? ? 〈ACC_A, DIRECT d〉))
     268            | REGISTER r ⇒ λregister6: True.
     269              Instruction (XRL ? (inl ? ? 〈ACC_A, REGISTER r〉))
     270            | DATA b ⇒ λdata : True.
     271              Instruction (XRL ? (inl ? ? 〈ACC_A, DATA b〉))
     272            | _ ⇒ Ⓧ
     273            ] (subaddressing_modein … reg')
     274          ]
     275        | LOAD _ _ _ ⇒ Instruction (MOVX ? (inl ? ? 〈ACC_A, EXT_INDIRECT_DPTR〉))
     276        | STORE _ _ _ ⇒ Instruction (MOVX ? (inr ? ? 〈EXT_INDIRECT_DPTR, ACC_A〉))
     277        | ADDRESS addr proof _ _ ⇒
     278          let look ≝ association addr globals (prf ? proof) in
     279            Instruction (MOV ? (inl ? ? (inl ? ? (inr ? ? (〈DPTR, (data16_of_int look)〉)))))
     280        | SET_CARRY ⇒
     281          Instruction (SETB ? CARRY)
     282        | MOVE regs ⇒
     283          match regs with
     284          [ to_acc _ reg ⇒
     285             let reg' ≝ register_address reg in
     286               match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
     287                                                              direct;
     288                                                              registr ]] x) → ? with
     289               [ REGISTER r ⇒ λregister9: True.
     290                 Instruction (MOV ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? 〈ACC_A, REGISTER r〉))))))
     291               | DIRECT d ⇒ λdirect9: True.
     292                 Instruction (MOV ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? 〈ACC_A, DIRECT d〉))))))
     293               | ACC_A ⇒ λacc_a: True.
     294                 Instruction (NOP ?)
     295               | _ ⇒ λother: False. ⊥
     296               ] (subaddressing_modein … reg')
     297          | from_acc reg _ ⇒
    207298             let reg' ≝ register_address reg in
    208299               match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
     
    217308               | _ ⇒ λother: False. ⊥
    218309               ] (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 _ _ ⇒
    235         let look ≝ association addr globals (prf ? proof) in
    236           Instruction (MOV ? (inl ? ? (inl ? ? (inr ? ? (〈DPTR, (data16_of_int look)〉)))))
     310          | int_to_reg reg bv ⇒
     311            let b ≝ asm_byte_of_beval bv in
     312            let reg' ≝ register_address reg in
     313              match reg' return λx. bool_to_Prop (is_in … [[ acc_a;
     314                                                             direct;
     315                                                             registr ]] x) → ? with
     316              [ REGISTER r ⇒ λregister7: True.
     317                Instruction (MOV ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? (inr ? ? 〈REGISTER r, DATA b〉))))))
     318              | ACC_A ⇒ λacc: True.
     319                Instruction (MOV ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? 〈ACC_A, DATA b〉))))))
     320              | DIRECT d ⇒ λdirect7: True.
     321                Instruction (MOV ? (inl ? ? (inl ? ? (inl ? ? (inr ? ? 〈DIRECT d, DATA b〉)))))
     322              | _ ⇒ λother: False. ⊥
     323              ] (subaddressing_modein … reg')
     324          | int_to_acc _ bv ⇒
     325            let b ≝ asm_byte_of_beval bv in
     326            Instruction (MOV ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? (inl ? ? 〈ACC_A, DATA b〉))))))
     327          ]
     328        ]
    237329      | COND _ lbl ⇒
    238330        (* dpm: this should be handled in translate_code! *)
    239331        Instruction (JNZ ? (toASM_ident ? lbl))
    240       | SET_CARRY ⇒
    241         Instruction (SETB ? CARRY)
    242332      ]
    243333    ].
     
    272362    match def with
    273363    [ Internal int ⇒
    274       let code ≝ joint_if_code … (lin_params globals_old) int in
     364      let code ≝ joint_if_code LIN globals_old int in
    275365      match translate_code globals globals_old prf code with
    276366      [ nil ⇒ ⊥
     
    293383let rec flatten_fun_defs
    294384  (globals: list (ident × nat)) (globals_old: list ident) (prf: ?) (initial_pc: nat)
    295     (the_list: list ((identifier SymbolTag) × (fundef (joint_internal_function globals_old (lin_params globals_old)))))
     385    (the_list: list ((identifier SymbolTag) × (fundef (joint_internal_function LIN globals_old))))
    296386      on the_list: ((list (option Identifier × pseudo_instruction)) × (identifier_map ? nat)) ≝
    297387  match the_list return λx. ((list (option Identifier × pseudo_instruction)) × (identifier_map ? nat)) with
  • src/LIN/joint_LTL_LIN.ma

    r1378 r2286  
    22
    33inductive registers_move: Type[0] ≝
    4  | from_acc: Register → registers_move
    5  | to_acc: Register → registers_move.
     4 | from_acc: Register → unit → registers_move
     5 | to_acc: unit → Register → registers_move
     6 | int_to_reg : Register → beval → registers_move
     7 | int_to_acc : unit → beval → registers_move.
     8(* the last is redudant, but kept for notation's sake *)
    69
    7 definition ltl_lin_params__: params__ ≝
    8  mk_params__ unit unit unit unit registers_move Register nat unit False.
    9 definition ltl_lin_params0 : params0 ≝ mk_params0 ltl_lin_params__ unit unit.
    10 definition ltl_lin_params1 : params1 ≝ mk_params1 ltl_lin_params0 unit.
     10inductive ltl_lin_seq : Type[0] ≝
     11| SAVE_CARRY : ltl_lin_seq
     12| RESTORE_CARRY : ltl_lin_seq.
     13
     14definition LTL_LIN : unserialized_params ≝ mk_unserialized_params
     15    (* acc_a_reg ≝ *) unit
     16    (* acc_b_reg ≝ *) unit
     17    (* acc_a_arg ≝ *) unit
     18    (* acc_b_arg ≝ *) unit
     19    (* dpl_reg   ≝ *) unit
     20    (* dph_reg   ≝ *) unit
     21    (* dpl_arg   ≝ *) unit
     22    (* dph_arg   ≝ *) unit
     23    (* snd_arg   ≝ *) hdw_argument
     24    (* pair_move ≝ *) registers_move
     25    (* call_args ≝ *) ℕ
     26    (* call_dest ≝ *) unit
     27    (* ext_seq ≝ *) ltl_lin_seq
     28    (* ext_call ≝ *) void
     29    (* ext_tailcall ≝ *) void
     30    (* paramsT ≝ *) unit
     31    (* localsT ≝ *) void.
     32
     33interpretation "move from acc" 'mov a b = (MOVE ?? (from_acc a b)).
     34interpretation "move to acc" 'mov a b = (MOVE ?? (to_acc a b)).
     35interpretation "move int to reg" 'mov a b = (MOVE ?? (int_to_reg a b)).
     36interpretation "move int to acc" 'mov a b = (MOVE ?? (int_to_acc a b)).
  • src/LIN/joint_LTL_LIN_semantics.ma

    r1451 r2286  
    44definition hw_reg_store ≝ λr,v,e. OK … (hwreg_store r v e).
    55definition hw_reg_retrieve ≝ λl,r. OK … (hwreg_retrieve l r).
     6definition hw_arg_retrieve ≝
     7  λl,a.match a with
     8  [ Reg r ⇒ hw_reg_retrieve l r
     9  | Imm b ⇒ OK … b
     10  ].
    611
    7 definition ltl_lin_more_sem_params: ∀succT. more_sem_params (mk_params_ ltl_lin_params__ succT) :=
    8  λsuccT.
    9  mk_more_sem_params ?
    10   unit it hw_register_env init_hw_register_env 0 it
    11    hw_reg_store hw_reg_retrieve (λ_.hw_reg_store RegisterA) (λe.λ_.hw_reg_retrieve e RegisterA)
    12     (λ_.hw_reg_store RegisterB) (λe.λ_.hw_reg_retrieve e RegisterB)
    13     (λ_.hw_reg_store RegisterDPL) (λe.λ_.hw_reg_retrieve e RegisterDPL)
    14     (λ_.hw_reg_store RegisterDPH) (λe.λ_.hw_reg_retrieve e RegisterDPH)
    15      (λlocals,dest_src.
    16        match dest_src with
    17        [ from_acc reg ⇒
    18           do v ← hw_reg_retrieve locals RegisterA ;
    19           hw_reg_store reg v locals
    20        | to_acc reg ⇒
    21           do v ← hw_reg_retrieve locals reg ;
    22           hw_reg_store RegisterA v locals ]).
     12definition eval_registers_move ≝ λe,m.
     13match m with
     14[ from_acc r _ ⇒
     15  hw_reg_store r (hwreg_retrieve e RegisterA) e
     16| to_acc _ r ⇒
     17  hw_reg_store RegisterA (hwreg_retrieve e r) e
     18| int_to_reg r v ⇒
     19  hw_reg_store r v e
     20| int_to_acc _ v ⇒
     21  hw_reg_store RegisterA v e
     22].
    2323
    24 definition ltl_lin_sem_params: ∀succT. sem_params ≝
    25  λsuccT.mk_sem_params … (ltl_lin_more_sem_params succT).
    26 
    27 
    28 definition ltl_lin_init_locals : unit → hw_register_env → hw_register_env ≝ λ_.λe.e.
    29 definition ltl_lin_pop_frame:
    30  ∀succT,codeT,lookup.
    31  ∀globals. genv globals (mk_params globals succT ltl_lin_params1 (codeT globals) (lookup globals)) →
    32  state … (ltl_lin_sem_params succT) → res (state … (ltl_lin_sem_params …)) ≝
    33  λ_.λ_.λ_.λ_.λ_.λt.OK … t.
    34 definition ltl_lin_save_frame:
    35  ∀succT. address → nat → unit → nat → unit → state … (ltl_lin_sem_params succT) → res (state … (ltl_lin_sem_params …)) ≝
    36  λ_.λl.λ_.λ_.λ_.λ_.λst.save_ra … st l.
    37 
    38 (* The following implementation only works for functions that return 32 bits *)
    39 definition ltl_lin_result_regs:
    40  ∀succT,codeT,lookup.
    41  ∀globals. genv globals (mk_params globals succT ltl_lin_params1 (codeT globals) (lookup globals)) →
    42  state (ltl_lin_sem_params succT) → res (list Register) ≝
    43  λ_.λ_.λ_.λ_.λ_.λ_. OK … RegisterRets.
     24definition LTL_LIN_state : sem_state_params ≝
     25  mk_sem_state_params
     26 (* framesT ≝ *) unit
     27 (* empty_framesT ≝ *) it
     28 (* regsT ≝ *) hw_register_env
     29 (* empty_regsT ≝ *) init_hw_register_env.
    4430
    4531(*CSC: XXXX, for external functions only*)
    46 axiom ltl_lin_fetch_external_args: ∀succT.external_function → state (ltl_lin_sem_params succT) → res (list val).
    47 axiom ltl_lin_set_result: ∀succT.list val → state (ltl_lin_sem_params succT) → res (state (ltl_lin_sem_params succT)).
     32axiom ltl_lin_fetch_external_args: external_function → state LTL_LIN_state → res (list val).
     33axiom ltl_lin_set_result: list val → unit → state LTL_LIN_state → res (state LTL_LIN_state).
    4834
    49 definition ltl_lin_exec_extended: ∀succT.∀p.∀globals. genv globals (p globals) → False → succT → state (ltl_lin_sem_params succT) → IO io_out io_in (trace × (state (ltl_lin_sem_params succT)))
    50  ≝ λsuccT,p,globals,ge,abs. ⊥.
    51 @abs qed.
     35(* TODO (needs another bit to be added to hdw) *)
     36axiom eval_ltl_lin_seq : ltl_lin_seq → state LTL_LIN_state → IO io_out io_in (state LTL_LIN_state).
    5237
    53 definition ltl_lin_more_sem_params2:
    54  ∀succT,codeT,lookup.∀succ: succT → address → res address.∀fetch.
    55  ∀pointer_of_label: ∀globals. genv globals
    56   (mk_params globals succT ltl_lin_params1 (codeT globals) (lookup globals))
    57   →pointer→label→res (Σp0:pointer.ptype p0=Code).
    58  ∀globals. more_sem_params2 … (mk_params globals succT ltl_lin_params1 (codeT globals) (lookup globals)) ≝
    59  λsuccT,codeT,lookup,succ,fetch,pointer_of_label,globals.
    60   mk_more_sem_params2 …
    61    (mk_more_sem_params1 … (ltl_lin_more_sem_params …)
    62     succ (pointer_of_label …) (fetch globals) (load_ra …) (ltl_lin_result_regs …)
    63     ltl_lin_init_locals (ltl_lin_save_frame …) (ltl_lin_pop_frame …)
    64     (ltl_lin_fetch_external_args …) (ltl_lin_set_result …)) (ltl_lin_exec_extended …).
    65 
    66 definition ltl_lin_fullexec ≝
    67  λsuccT,codeT,lookup,succ,fetch,pointer_of_label.
    68   joint_fullexec … (λp. ltl_lin_more_sem_params2 succT codeT lookup succ fetch pointer_of_label (prog_var_names … p)).
     38definition LTL_LIN_semantics ≝
     39  λF.mk_more_sem_unserialized_params LTL_LIN F
     40  (* st_pars            ≝ *) LTL_LIN_state
     41  (* acca_store_        ≝ *) (λ_.hw_reg_store RegisterA)
     42  (* acca_retrieve_     ≝ *) (λe.λ_.hw_reg_retrieve e RegisterA)
     43  (* acca_arg_retrieve_ ≝ *) (λe.λ_.hw_reg_retrieve e RegisterA)
     44  (* accb_store_        ≝ *) (λ_.hw_reg_store RegisterB)
     45  (* accb_retrieve_     ≝ *) (λe.λ_.hw_reg_retrieve e RegisterB)
     46  (* accb_arg_retrieve_ ≝ *) (λe.λ_.hw_reg_retrieve e RegisterB)
     47  (* dpl_store_         ≝ *) (λ_.hw_reg_store RegisterDPL)
     48  (* dpl_retrieve_      ≝ *) (λe.λ_.hw_reg_retrieve e RegisterDPL)
     49  (* dpl_arg_retrieve_  ≝ *) (λe.λ_.hw_reg_retrieve e RegisterDPL)
     50  (* dph_store_         ≝ *) (λ_.hw_reg_store RegisterDPH)
     51  (* dph_retrieve_      ≝ *) (λe.λ_.hw_reg_retrieve e RegisterDPH)
     52  (* dph_arg_retrieve_  ≝ *) (λe.λ_.hw_reg_retrieve e RegisterDPH)
     53  (* snd_arg_retrieve_  ≝ *) hw_arg_retrieve
     54  (* pair_reg_move_     ≝ *) eval_registers_move
     55  (* fetch_ra           ≝ *) (load_ra …)
     56  (* allocate_local     ≝ *) (λabs.match abs in void with [ ])
     57  (* save_frame         ≝ *) (λp.λ_.λst.save_ra … st p)
     58  (* setup_call         ≝ *) (λ_.λ_.λ_.λst.return st)
     59  (* fetch_external_args≝ *) ltl_lin_fetch_external_args
     60  (* set_result         ≝ *) ltl_lin_set_result
     61  (* call_args_for_main ≝ *) 0
     62  (* call_dest_for_main ≝ *) it
     63  (* read_result        ≝ *) (λ_.λ_.λ_.
     64  λst.return map … (hwreg_retrieve (regs … st)) RegisterRets)
     65  (* eval_ext_seq       ≝ *) (λ_.λ_.λs.λ_.eval_ltl_lin_seq s)
     66  (* eval_ext_tailcall  ≝ *) (λ_.λ_.λabs.match abs in void with [ ])
     67  (* eval_ext_call      ≝ *) (λ_.λ_.λabs.match abs in void with [ ])
     68  (* pop_frame          ≝ *) (λ_.λ_.λ_.λst.return st)
     69  (* post_op2           ≝ *) (λ_.λ_.λ_.λ_.λ_.λ_.λst.st).
  • src/LIN/semantics.ma

    r1601 r2286  
    22include "LIN/LIN.ma". (* CSC: syntax.ma in RTLabs *)
    33
    4 definition lin_succ_pc: unit → address → res address :=
    5  λ_.λaddr. addr_add addr 1.
    6 
    7 axiom BadOldPointer: String.
    8 (*CSC: XXX factorize the code with graph_fetch_function!!! *)
    9 definition lin_fetch_function:
    10  ∀globals. genv … (lin_params globals) → pointer → res (joint_internal_function globals (lin_params globals)) ≝
    11  λglobals,ge,old.
    12   let b ≝ pblock old in
    13   do def ← opt_to_res ? [MSG BadOldPointer] (find_funct_ptr … ge b);
    14   match def with
    15   [ Internal fn ⇒ OK … fn
    16   | External _ ⇒ Error … [MSG BadOldPointer]].
    17 
    18 axiom BadLabel: String.
    19 definition lin_pointer_of_label:
    20  ∀globals. genv … (lin_params globals) → pointer → label → res (Σp:pointer. ptype p = Code) ≝
    21  λglobals,ge,old,l.
    22   do fn ← lin_fetch_function … ge old ;
    23   do pos ←
    24    opt_to_res ? [MSG BadLabel]
    25     (position_of ?
    26       (λs. let 〈l',x〉 ≝ s in
    27         match l' with [ None ⇒ false | Some l'' ⇒ if eq_identifier … l l'' then true else false])
    28      (joint_if_code … (lin_params …) fn)) ;
    29   OK … (mk_Sig … (mk_pointer Code (mk_block Code (block_id (pblock old))) ? (mk_offset pos)) ?).
    30 // qed.
    31 
    32 (*CSC: XXX factorize code with graph_fetch_statement?*)
    33 axiom BadProgramCounter: String.
    34 definition lin_fetch_statement:
    35  ∀globals. genv … (lin_params globals) → state (ltl_lin_sem_params unit) → res (pre_lin_statement globals) ≝
    36  λglobals,ge,st.
    37   do ppc ← pointer_of_address (pc … st) ;
    38   do fn ← lin_fetch_function … ge ppc ;
    39   let off ≝ abs (offv (poff ppc)) in (* The offset should always be positive! *)
    40   do found ← opt_to_res ? [MSG BadProgramCounter] (nth_opt ? off (joint_if_code … fn)) ;
    41   OK … (\snd found).
    42 
    43 definition lin_fullexec: fullexec io_out io_in ≝
    44  ltl_lin_fullexec … lin_succ_pc … lin_fetch_statement lin_pointer_of_label.
     4definition LIN_semantics : sem_params ≝
     5  make_sem_lin_params LIN (LTL_LIN_semantics ?).
  • src/LTL/LTL.ma

    r1378 r2286  
    11include "LIN/joint_LTL_LIN.ma".
    22
    3 definition ltl_params_ : params_ ≝ graph_params_ ltl_lin_params__.
    4 definition ltl_params: ∀globals. params globals ≝ graph_params ltl_lin_params1.
     3definition LTL ≝ mk_graph_params LTL_LIN.
    54
    6 definition ltl_statement ≝ joint_statement ltl_params_.
    7 definition ltl_program ≝ joint_program ltl_params.
     5(* aid unification *)
     6unification hint 0 ≔
     7(*---------------*) ⊢
     8acc_a_reg LTL ≡ unit.
     9unification hint 0 ≔
     10(*---------------*) ⊢
     11acc_a_arg LTL ≡ unit.
     12unification hint 0 ≔
     13(*---------------*) ⊢
     14acc_b_reg LTL ≡ unit.
     15unification hint 0 ≔
     16(*---------------*) ⊢
     17acc_a_arg LTL ≡ unit.
     18unification hint 0 ≔
     19(*---------------*) ⊢
     20snd_arg LTL ≡ hdw_argument.
     21unification hint 0 ≔
     22(*---------------*) ⊢
     23ext_seq LTL ≡ ltl_lin_seq.
     24unification hint 0 ≔
     25(*---------------*) ⊢
     26pair_move LTL ≡ registers_move.
    827
    9 definition ltl_internal_function ≝
    10  λglobals. joint_internal_function … (ltl_params globals).
     28definition ltl_program ≝ joint_program LTL.
     29
     30coercion byte_to_ltl_argument : ∀b: Byte.snd_arg LTL ≝
     31  hdw_argument_from_byte on _b : Byte to snd_arg LTL.
     32coercion reg_to_ltl_argument : ∀r: Register.snd_arg LTL ≝
     33  hdw_argument_from_reg on _r : Register to snd_arg LTL.
  • src/LTL/LTLToLIN.ma

    r2205 r2286  
     1include "joint/linearise.ma".
    12include "LTL/LTL.ma".
    23include "LIN/LIN.ma".
    3 include "utilities/BitVectorTrieSet.ma".
    4 include alias "common/Graphs.ma".
    5 
    6 definition translate_statement: ∀globals. ltl_statement globals → pre_lin_statement globals ≝
    7   λglobals: list ident.
    8   λs: ltl_statement globals.
    9   match s with
    10   [ RETURN ⇒ RETURN ??
    11   | sequential instr lbl ⇒ sequential … instr it
    12   | GOTO l ⇒ GOTO lin_params_ globals l
    13   ].
    14 
    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. *)
    20 let rec visit
    21   (globals: list ident) (g: label → option (ltl_statement globals))
    22   (required: identifier_set LabelTag) (visited: identifier_set LabelTag)
    23   (generated: list (lin_statement globals)) (l: label) (n: nat)
    24     on n: identifier_set LabelTag × (list (lin_statement globals)) ≝
    25   match n with
    26   [ O ⇒ ⊥ (* CSC: Case to be made impossible; use dummy value? *)
    27   | S n' ⇒
    28     if l∈visited then
    29      〈add_set ? required l, 〈None …, GOTO … globals l〉 :: generated〉
    30     else
    31      let visited' ≝ add_set ? visited l in
    32      match g 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'' ≝ add_set ? required' l1 in
    44              if 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 *) ]
    52 qed.
    53 
    54 (* CSC: The branch compression (aka tunneling) optimization is not implemented
    55    in Matita *)
    56 definition branch_compress ≝ λglobals.λa:label → option (ltl_statement globals).a.
    57 
    58 definition 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 ≝ ∅ in
    65   let required ≝ { (entry) } in
    66   let 〈required', translated〉 ≝ visit globals g required visited [ ] entry labels_upper_bound in
    67   let reversed ≝ rev ? translated in
    68    map ??
    69     (λs. let 〈l,x〉 ≝ s in
    70       match l with
    71        [ None ⇒ 〈None …,x〉
    72        | Some l ⇒
    73           〈if l ∈ required' then Some ? l else None ?,
    74            x〉])
    75     reversed.
    76 
    77 definition translate_int_fun:
    78  ∀globals.
    79   joint_internal_function … (ltl_params globals) →
    80    joint_internal_function … (lin_params globals)
    81 
    82  λglobals,f.
    83   mk_joint_internal_function globals (lin_params globals)
    84    (joint_if_luniverse ?? f) (joint_if_runiverse ?? f) it it it (joint_if_stacksize ?? f)
    85     (translate_graph globals (joint_if_entry ?? f) (nat_of_pos … (next_identifier … (joint_if_luniverse … f)))
    86      (lookup ?? (joint_if_code … f)))
    87     ??.
    88 cases daemon (*CSC: XXXXXXXXX Dead code produced *)
    89 qed.
    904
    915definition ltl_to_lin : ltl_program → lin_program ≝
    92  λp. transform_program … p (λvarnames. transf_fundef … (translate_int_fun varnames)).
     6 λp. transform_program … p (λvarnames. transf_fundef … (linearise_int_fun LTL_LIN varnames)).
  • src/LTL/semantics.ma

    r1451 r2286  
    22include "LTL/LTL.ma". (* CSC: syntax.ma in RTLabs *)
    33
    4 definition ltl_fullexec : fullexec io_out io_in ≝
    5  ltl_lin_fullexec … graph_succ_p (graph_fetch_statement … (ltl_lin_sem_params …))
    6   (graph_pointer_of_label …).
     4definition LTL_semantics : sem_params ≝
     5  make_sem_graph_params LTL (LTL_LIN_semantics ?).
  • src/RTL/RTL.ma

    r1348 r2286  
    11include "joint/Joint.ma".
    22
    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. *)
    6 inductive rtl_statement_extension: Type[0] ≝
    7   | rtl_st_ext_stack_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.
     3inductive rtl_seq : Type[0] ≝
     4  | rtl_stack_address: register → register → rtl_seq.
     5 
     6inductive rtl_call : Type[0] ≝
     7  | rtl_call_ptr: register → register → list psd_argument → list register → rtl_call.
    118
    12 definition rtl_params__: params__ ≝
    13  mk_params__ register register register register (register × register) register
    14   (list register) (list register) rtl_statement_extension.
    15 definition rtl_params_: params_ ≝ graph_params_ rtl_params__.
    16 definition rtl_params0: params0 ≝ mk_params0 rtl_params__ (list register) (list register).
    17 definition rtl_params1: params1 ≝ rtl_ertl_params1 rtl_params0.
    18 definition rtl_params: ∀globals. params globals ≝ rtl_ertl_params rtl_params0.
     9inductive rtl_tailcall : Type[0] ≝
     10  | rtl_tailcall_id: ident → list psd_argument → rtl_tailcall
     11  | rtl_tailcall_ptr: register → register → list psd_argument → rtl_tailcall.
    1912
    20 definition rtl_statement ≝ joint_statement rtl_params_.
     13definition RTL_uns ≝ mk_unserialized_params
     14    (* acc_a_reg ≝ *) register
     15    (* acc_b_reg ≝ *) register
     16    (* acc_a_arg ≝ *) psd_argument
     17    (* acc_b_arg ≝ *) psd_argument
     18    (* dpl_reg   ≝ *) register
     19    (* dph_reg   ≝ *) register
     20    (* dpl_arg   ≝ *) psd_argument
     21    (* dph_arg   ≝ *) psd_argument
     22    (* snd_arg   ≝ *) psd_argument
     23    (* pair_move ≝ *) (register × psd_argument)
     24    (* call_args ≝ *) (list psd_argument)
     25    (* call_dest ≝ *) (list register)
     26    (* ext_seq ≝ *) rtl_seq
     27    (* ext_call ≝ *) rtl_call
     28    (* ext_tailcall ≝ *) rtl_tailcall
     29    (* paramsT ≝ *) (list register)
     30    (* localsT ≝ *) register.
    2131
    22 definition rtl_internal_function ≝
    23   λglobals. joint_internal_function … (rtl_params globals).
     32definition RTL ≝ mk_graph_params RTL_uns.
     33definition rtl_program ≝ joint_program RTL.
    2434
    25 definition rtl_program ≝ joint_program rtl_params.
     35interpretation "move" 'mov r a = (MOVE RTL ? (mk_Prod ? psd_argument r a)).
     36
     37(* aid unification *)
     38include "hints_declaration.ma".
     39unification hint 0 ≔
     40(*---------------*) ⊢
     41acc_a_reg RTL ≡ register.
     42unification hint 0 ≔
     43(*---------------*) ⊢
     44acc_b_reg RTL ≡ register.
     45unification hint 0 ≔
     46(*---------------*) ⊢
     47acc_a_arg RTL ≡ psd_argument.
     48unification hint 0 ≔
     49(*---------------*) ⊢
     50acc_b_arg RTL ≡ psd_argument.
     51unification hint 0 ≔
     52(*---------------*) ⊢
     53dpl_reg RTL ≡ register.
     54unification hint 0 ≔
     55(*---------------*) ⊢
     56dph_reg RTL ≡ register.
     57unification hint 0 ≔
     58(*---------------*) ⊢
     59dpl_arg RTL ≡ psd_argument.
     60unification hint 0 ≔
     61(*---------------*) ⊢
     62dph_arg RTL ≡ psd_argument.
     63unification hint 0 ≔
     64(*---------------*) ⊢
     65snd_arg RTL ≡ psd_argument.
     66unification hint 0 ≔
     67(*---------------*) ⊢
     68pair_move RTL ≡ register × psd_argument.
     69unification hint 0 ≔
     70(*---------------*) ⊢
     71call_args RTL ≡ list psd_argument.
     72unification hint 0 ≔
     73(*---------------*) ⊢
     74call_dest RTL ≡ list register.
     75
     76unification hint 0 ≔
     77(*---------------*) ⊢
     78ext_seq RTL ≡ rtl_seq.
     79unification hint 0 ≔
     80(*---------------*) ⊢
     81ext_call RTL ≡ rtl_call.
     82unification hint 0 ≔
     83(*---------------*) ⊢
     84ext_tailcall RTL ≡ rtl_tailcall.
     85
     86coercion reg_to_rtl_snd_argument : ∀r : register.snd_arg RTL ≝ psd_argument_from_reg
     87  on _r : register to snd_arg RTL.
     88coercion byte_to_rtl_snd_argument : ∀b : Byte.snd_arg RTL ≝ psd_argument_from_byte
     89  on _b : Byte to snd_arg RTL.
     90
    2691
    2792(************ Same without tail calls ****************)
    2893
    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. *)
    32 inductive rtlntc_statement_extension: Type[0] ≝
    33   | rtlntc_st_ext_stack_address: register → register → rtlntc_statement_extension
    34   | rtlntc_st_ext_call_ptr: register → register → list register → list register → rtlntc_statement_extension.
     94definition RTL_ntc ≝ mk_graph_params (mk_unserialized_params
     95    (* acc_a_reg ≝ *) register
     96    (* acc_b_reg ≝ *) register
     97    (* acc_a_arg ≝ *) psd_argument
     98    (* acc_b_arg ≝ *) psd_argument
     99    (* dpl_reg   ≝ *) register
     100    (* dph_reg   ≝ *) register
     101    (* dpl_arg   ≝ *) psd_argument
     102    (* dph_arg   ≝ *) psd_argument
     103    (* snd_arg   ≝ *) psd_argument
     104    (* pair_move ≝ *) (register × psd_argument)
     105    (* call_args ≝ *) (list psd_argument)
     106    (* call_dest ≝ *) (list register)
     107    (* ext_seq ≝ *) rtl_seq
     108    (* ext_call ≝ *) rtl_call
     109    (* ext_tailcall ≝ *) void
     110    (* paramsT ≝ *) (list register)
     111    (* localsT ≝ *) register).
    35112
    36 definition rtlntc_params__: params__ ≝
    37  mk_params__ register register register register (register × register) register
    38   (list register) (list register) rtlntc_statement_extension.
    39 definition rtlntc_params_: params_ ≝ graph_params_ rtlntc_params__.
    40 definition rtlntc_params0: params0 ≝ mk_params0 rtlntc_params__ (list register) (list register).
    41 definition rtlntc_params1: params1 ≝ rtl_ertl_params1 rtlntc_params0.
    42 definition rtlntc_params: ∀globals. params globals ≝ rtl_ertl_params rtlntc_params0.
    43 
    44 definition rtlntc_statement ≝ joint_statement rtlntc_params_.
    45 
    46 definition rtlntc_internal_function ≝
    47   λglobals. joint_internal_function … (rtlntc_params globals).
    48 
    49 definition rtlntc_program ≝ joint_program rtlntc_params.
     113definition rtl_ntc_program ≝ joint_program RTL_ntc.
  • src/RTL/RTLTailcall.ma

    r2103 r2286  
    55  λexit: label.
    66  λlbl: label.
    7   λstmt: rtl_statement globals.
    8   λgraph: codeT … (rtlntc_params globals).
     7  λstmt: joint_statement RTL globals.
     8  λgraph: codeT RTL_ntc globals.
    99  match stmt with
    10   [ sequential seq DUMMY
    11      match seq with
    12       [ extension ext ⇒
     10  [ final fin
     11     match fin with
     12      [ tailcall ext ⇒
    1313         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 ]
     14          [ rtl_tailcall_id f args ⇒
     15              add … graph lbl (sequential … (CALL_ID RTL_ntc ? f args [ ]) exit)
     16          | rtl_tailcall_ptr f1 f2 args ⇒
     17              add … graph lbl (sequential RTL_ntc ? (rtl_call_ptr f1 f2 args [ ] : ext_call RTL_ntc) exit)
     18          ]
    1919      | _ ⇒ graph ]
    2020  | _ ⇒ graph ].
     
    2323  λglobals.
    2424  λexit: label.
    25   λgraph: codeT … (rtl_params globals).
     25  λgraph: codeT RTL globals.
    2626    foldi ? ? ? (simplify_stmt globals exit) graph (empty_map …).
    2727
    2828axiom simplify_graph_preserves_labels:
    2929  ∀globals.
    30   ∀g: codeT … (rtl_params globals).
    31   ∀l: label.
     30  ∀g: codeT RTL globals.
    3231  ∀exit: label.
    33     lookup ? ? g l ≠ None ? → lookup ? ? (simplify_graph globals exit g) l ≠ None ?.
     32  ∀l: label.l ∈ g → l ∈ simplify_graph globals exit g.
    3433   
    3534definition simplify_internal :
    3635 ∀globals.
    37   joint_internal_function … (rtl_params globals)
    38    joint_internal_function … (rtlntc_params globals)
     36  joint_internal_function RTL globals
     37   joint_internal_function RTL_ntc globals
    3938
    4039  λglobals,def.
     
    4948qed.
    5049
    51 definition tailcall_simplify : rtl_program → rtlntc_program ≝
     50definition tailcall_simplify : rtl_program → rtl_ntc_program ≝
    5251 λp. transform_program … p (λvarnames. transf_fundef … (simplify_internal varnames)).
  • src/RTL/RTLToERTL.ma

    r2103 r2286  
    77include alias "basics/lists/list.ma".
    88
    9 definition save_hdws ≝
    10  λglobals,l.
     9definition ertl_fresh_reg:
     10 ∀globals.freshT ERTL globals register ≝
     11  λglobals,def.
     12    let 〈r, runiverse〉 ≝ fresh … (joint_if_runiverse … def) in
     13    〈set_locals ?? (set_runiverse ?? def runiverse)(r::joint_if_locals ?? def), r〉.
     14
     15definition save_hdws :
     16  ∀globals.list (register×Register) → list (joint_seq ERTL globals) ≝
     17 λglobals.
    1118  let save_hdws_internal ≝
    12    λdestr_srcr.λstart_lbl.
    13     let 〈destr, srcr〉 ≝ destr_srcr in
    14      adds_graph ertl_params1 globals [ sequential ertl_params_ … (MOVE … 〈pseudo destr,hardware srcr〉) ] start_lbl
    15   in
    16    map ? ? save_hdws_internal l.
    17 
    18 definition restore_hdws ≝
    19   λglobals,l.
     19   λdestr_srcr.PSD (\fst destr_srcr) ← HDW (\snd destr_srcr) in
     20  map ?? save_hdws_internal.
     21
     22definition restore_hdws :
     23  ∀globals.list (psd_argument×Register) → list (joint_seq ERTL globals) ≝
     24  λglobals.
    2025   let restore_hdws_internal ≝
    21     λsrcr_destr: register × Register.
    22     λstart_lbl: label.
    23      let 〈srcr, destr〉 ≝ srcr_destr in
    24      adds_graph ertl_params1 globals [ sequential ertl_params_ … (MOVE … 〈hardware destr, pseudo srcr〉) ] start_lbl
    25    in
    26     map ? ? restore_hdws_internal l.
    27 
    28 definition get_params_hdw ≝
    29   λglobals.
    30   λparams: list register.
    31   match params with
    32   [ nil ⇒ [λstart_lbl: label. adds_graph ertl_params1 globals [ GOTO … ] start_lbl]
    33   | _ ⇒
    34     let l ≝ zip_pottier ? ? params RegisterParams in
    35       save_hdws globals l ].
    36 
    37 definition get_param_stack ≝
    38   λglobals.
    39   λoff: nat.
    40   λdestr.
    41   λstart_lbl, dest_lbl: label.
    42   λdef.
    43   let 〈def, addr1〉 ≝ fresh_reg … def in
    44   let 〈def, addr2〉 ≝ fresh_reg … def in
    45   let 〈def, tmpr〉 ≝ fresh_reg … def in
    46   let 〈carry, int_offset〉 ≝ half_add ? (bitvector_of_nat ? off) int_size in
    47   adds_graph ertl_params1 globals [
    48     sequential ertl_params_ … (extension … (ertl_st_ext_frame_size addr1));
    49     sequential ertl_params_ … (INT … tmpr int_offset);
    50     sequential ertl_params_ … (OP2 … Sub addr1 addr1 tmpr);
    51     sequential ertl_params_ … (MOVE … 〈pseudo tmpr, hardware RegisterSPL〉);
    52     sequential ertl_params_ … (OP2 … Add addr1 addr1 tmpr);
    53     sequential ertl_params_ … (INT … addr2 (bitvector_of_nat 8 0));
    54     sequential ertl_params_ … (MOVE … 〈pseudo tmpr, hardware RegisterSPH〉);
    55     sequential ertl_params_ … (OP2 … Addc addr2 addr2 tmpr);
    56     sequential ertl_params_ … (LOAD … destr addr1 addr2)
    57   ] start_lbl dest_lbl def.
    58  
    59 definition get_params_stack ≝
    60   λglobals,params.
    61   match params with
    62   [ nil ⇒ [ λstart_lbl. adds_graph … [GOTO …] start_lbl ]
    63   | _ ⇒ mapi ? ? (get_param_stack globals) params ].
     26    λdestr_srcr:psd_argument×?.HDW (\snd destr_srcr) ← \fst destr_srcr in
     27    map ? ? restore_hdws_internal.
     28
     29definition get_params_hdw :
     30  ∀globals.list register → list (joint_seq ERTL globals) ≝
     31  λglobals,params.
     32  save_hdws … (zip_pottier … params RegisterParams).
     33
     34definition get_param_stack :
     35  ∀globals.register → register → register →
     36  list (joint_seq ERTL globals) ≝
     37  λglobals,addr1,addr2,destr.
     38  (* liveness analysis will erase the last useless ops *)
     39  [ LOAD ?? destr addr1 addr2 ;
     40    addr1 ← addr1 .Add. (int_size : Byte) ;
     41    addr2 ← addr2 .Addc. zero_byte
     42  ].
     43
     44definition get_params_stack :
     45  ∀globals.list register →
     46  bind_new (localsT ERTL) (list (joint_seq ERTL globals)) ≝
     47  λglobals,params.
     48  νtmpr,addr1,addr2 in
     49  let params_length_byte : Byte ≝ bitvector_of_nat ? (|params|) in
     50  [ (ertl_frame_size tmpr : joint_seq ??) ;
     51    CLEAR_CARRY ?? ;
     52    tmpr ← tmpr .Sub. params_length_byte ; (* will be constant later *)
     53    PSD addr1 ← HDW RegisterSPL ;
     54    PSD addr2 ← HDW RegisterSPH ;
     55    addr1 ← addr1 .Add. tmpr ;
     56    addr2 ← addr2 .Addc. zero_byte ] @   
     57  flatten … (map ?? (get_param_stack globals addr1 addr2) params).
    6458
    6559definition get_params ≝
     
    6761  let n ≝ min (length … params) (length … RegisterParams) in
    6862  let 〈hdw_params, stack_params〉 ≝ list_split … n params in
    69   let hdw_params ≝ get_params_hdw globals hdw_params in
    70     hdw_params @ (get_params_stack … stack_params).
    71 
    72 definition add_prologue ≝
    73   λglobals.
    74   λparams: list register.
    75   λsral.
    76   λsrah.
    77   λsregs.
    78   λdef.
    79   let start_lbl ≝ joint_if_entry … (ertl_params globals) def in
    80   let 〈tmp_lbl, def〉 ≝ fresh_label … def in
    81   match lookup … (joint_if_code … def) start_lbl
    82     return λx. x ≠ None ? → ertl_internal_function globals with
    83   [ None ⇒ λnone_absrd. ⊥
    84   | Some last_stmt ⇒ λsome_prf.
    85     let def ≝
    86       add_translates …
    87          ((adds_graph ertl_params1 … [
    88                      sequential ertl_params_ … (extension ertl_params__ globals ertl_st_ext_new_frame)
    89                    ]) ::
    90          (adds_graph ertl_params1 … [
    91                       sequential ertl_params_ … (POP … sral);
    92                       sequential ertl_params_ … (POP … srah)
    93                    ]) ::
    94          (save_hdws … sregs) @
    95          (get_params … params))
    96         start_lbl tmp_lbl def
    97     in
    98       add_graph … tmp_lbl last_stmt def
    99   ] ?.
    100 [ cases start_lbl #x #H cases daemon (* @H *) (*CSC: XXXX, no Russell *)
    101 | cases (none_absrd) /2/ ]
    102 qed.
    103 
    104 definition save_return ≝
    105   λglobals.
    106   λret_regs.
    107   λstart_lbl: label.
    108   λdest_lbl: label.
    109   λdef: ertl_internal_function globals.
    110   let 〈def, tmpr〉 ≝ fresh_reg … def in
     63  get_params_hdw globals hdw_params @@ get_params_stack … stack_params.
     64
     65definition prologue :
     66  ∀globals.list register → register → register → list (register×Register) →
     67  bind_new (localsT ERTL) (list (joint_seq ERTL globals)) ≝
     68  λglobals,params,sral,srah,sregs.
     69  [ (ertl_new_frame : joint_seq ??) ;
     70    POP … sral ;
     71    POP … srah
     72  ] @@ save_hdws … sregs @@ get_params … params.
     73
     74definition save_return :
     75  ∀globals.list psd_argument → list (joint_seq ERTL globals) ≝
     76  λglobals,ret_regs.
    11177  match reduce_strong ? ? RegisterSTS ret_regs with
    11278  [ mk_Sig crl crl_proof ⇒
     
    11480    let commonr ≝ \fst (\snd crl) in
    11581    let restl ≝ \snd (\fst crl) in
    116     let restr ≝ \snd (\snd crl) in
    117     let init_tmpr ≝ sequential ertl_params_ … (INT … tmpr (zero …)) in
    118     let f_save ≝ λst. λr. sequential ertl_params_ … (MOVE … 〈hardware st, pseudo r〉) in
    119     let saves ≝ map2 … f_save commonl commonr crl_proof in
    120     let f_default ≝ λst. sequential ertl_params_ … (MOVE … 〈hardware st, pseudo tmpr〉) in
    121     let defaults ≝ map … f_default restl in
    122       adds_graph ertl_params1 ? (init_tmpr :: saves @ defaults) start_lbl dest_lbl def
    123   ].
    124 
    125 definition assign_result ≝
    126   λglobals.λstart_lbl: label.
    127   match reduce_strong ? ? RegisterRets RegisterSTS with
     82    (* let restr ≝ \snd (\snd crl) in *)
     83    map2 … (λst.λr : psd_argument.HDW st ← r) commonl commonr crl_proof @
     84    map … (λst.HDW st ← zero_byte) restl
     85  ].
     86
     87definition assign_result : ∀globals.list (joint_seq ERTL globals) ≝
     88  λglobals.
     89  match reduce_strong ?? RegisterRets RegisterSTS with
    12890  [ mk_Sig crl crl_proof ⇒
    12991    let commonl ≝ \fst (\fst crl) in
    13092    let commonr ≝ \fst (\snd crl) in
    131     let f ≝ λret. λst. sequential ertl_params_ globals (MOVE … 〈hardware ret, hardware st〉) in
    132     let insts ≝ map2 ? ? ? f commonl commonr crl_proof in
    133       adds_graph ertl_params1 … insts start_lbl
    134   ].
    135 
    136 definition add_epilogue ≝
    137   λglobals.
    138   λret_regs.
    139   λsral.
    140   λsrah.
    141   λsregs.
    142   λdef.
    143   let start_lbl ≝ joint_if_exit … (ertl_params globals) def in
    144   let 〈tmp_lbl, def〉 ≝ fresh_label … def in
    145   match lookup … (joint_if_code … def) start_lbl
    146     return λx. x ≠ None ? → ertl_internal_function globals with
    147   [ None ⇒ λnone_absrd. ⊥
    148   | Some last_stmt ⇒ λsome_prf.
    149     let def ≝
    150       add_translates ertl_params1 … (
    151         [save_return globals ret_regs] @
    152         restore_hdws … sregs @
    153         [adds_graph ertl_params1 … [
    154           sequential ertl_params_ … (PUSH … srah);
    155           sequential ertl_params_ … (PUSH … sral)
    156         ]] @
    157         [adds_graph ertl_params1 … [
    158           sequential ertl_params_ … (extension … ertl_st_ext_del_frame)
    159         ]] @
    160         [assign_result globals]
    161       ) start_lbl tmp_lbl def
    162     in
    163     let def' ≝ add_graph … tmp_lbl last_stmt def in
    164       set_joint_if_exit … tmp_lbl def' ?
    165   ] ?.
    166 [ cases start_lbl #x #H cases daemon (* @H *) (* CSC: XXXX *)
    167 | cases (none_absrd) /2/
    168 | cases daemon (* CSC: XXXXX *)
    169 ]
    170 qed.
    171  
    172 
    173 definition allocate_regs ≝
    174   λglobals.
    175   λrs.
    176   λsaved: rs_set rs.
    177   λdef.
     93    map2 … (λret,st.HDW ret ← HDW st) commonl commonr crl_proof
     94  ].
     95
     96definition epilogue :
     97  ∀globals.list register → register → register → list (register × Register) →
     98  list (joint_seq ERTL globals) ≝
     99  λglobals,ret_regs,sral,srah,sregs.
     100  save_return … (map … (Reg ?) ret_regs) @
     101  restore_hdws … (map … (λpr.〈Reg ? (\fst pr),\snd pr〉) sregs) @
     102  [ PUSH ERTL ? srah ;
     103    PUSH … sral ;
     104    ertl_del_frame ] @
     105  assign_result globals.
     106
     107definition allocate_regs :
     108  ∀globals,rs.rs_set rs →
     109  freshT ERTL globals (list (register×Register)) ≝
     110  λglobals,rs,saved,def.
    178111   let allocate_regs_internal ≝
    179112    λr: Register.
    180113    λdef_sregs.
    181     let 〈def, sregs〉 ≝ def_sregs in
    182     let 〈def, r'〉 ≝ fresh_reg ertl_params0 globals def in
    183       〈def, 〈r', r〉 :: sregs〉
    184    in
    185     rs_fold ? ? allocate_regs_internal saved 〈def, [ ]〉.
    186    
    187 definition add_pro_and_epilogue ≝
    188   λglobals.
    189   λparams.
    190   λret_regs.
    191   λdef.
    192   match fresh_regs_strong … globals def 2 with
    193   [ mk_Sig def_sra def_sra_proof ⇒
    194     let def ≝ \fst def_sra in
    195     let sra ≝ \snd def_sra in
    196     let sral ≝ nth_safe ? 0 sra ? in
    197     let srah ≝ nth_safe ? 1 sra ? in
    198     let 〈def, sregs〉 ≝ allocate_regs … register_list_set RegisterCalleeSaved def in
    199     let def ≝ add_prologue … params sral srah sregs def in
    200     let def ≝ add_epilogue … ret_regs sral srah sregs def in
    201       def
    202   ].
    203 >def_sra_proof //
    204 qed.
    205 
    206 definition set_params_hdw ≝
    207   λglobals,params.
    208   match params with
    209   [ nil ⇒ [ λstart_lbl. adds_graph … [GOTO …] start_lbl]
    210   | _ ⇒
    211     let l ≝ zip_pottier ? ? params RegisterParams in
    212       restore_hdws globals l
    213   ].
    214 
    215 definition set_param_stack ≝
    216   λglobals.
    217   λoff.
    218   λsrcr.
    219   λstart_lbl: label.
    220   λdest_lbl: label.
    221   λdef: ertl_internal_function globals.
    222   let 〈def, addr1〉 ≝ fresh_reg … def in
    223   let 〈def, addr2〉 ≝ fresh_reg … def in
    224   let 〈def, tmpr〉 ≝ fresh_reg … def in
    225   let 〈ignore, int_off〉 ≝ half_add ? off int_size in
    226     adds_graph ertl_params1 … [
    227       sequential ertl_params_ … (INT … addr1 int_off);
    228       sequential ertl_params_ … (MOVE … 〈pseudo tmpr, hardware RegisterSPL〉);
    229       sequential ertl_params_ … (CLEAR_CARRY …);
    230       sequential ertl_params_ … (OP2 … Sub addr1 tmpr addr1);
    231       sequential ertl_params_ … (MOVE … 〈pseudo tmpr, hardware RegisterSPH〉);
    232       sequential ertl_params_ … (INT … addr2 (zero ?));
    233       sequential ertl_params_ … (OP2 … Sub addr2 tmpr addr2);
    234       sequential ertl_params_ … (STORE … addr1 addr2 srcr)
    235     ] start_lbl dest_lbl def.   
    236 
    237 definition set_params_stack ≝
    238   λglobals,params.
    239   match params with
    240   [ nil ⇒ [ λstart_lbl. adds_graph ertl_params1 globals [GOTO …] start_lbl]
    241   | _ ⇒
    242     let f ≝ λi. λr. set_param_stack … (bitvector_of_nat ? i) r in
    243       mapi ? ? f params].
     114    let 〈def, r'〉 ≝ ertl_fresh_reg … (\fst def_sregs) in
     115    〈def, 〈r', r〉::\snd def_sregs〉 in
     116  rs_fold ?? allocate_regs_internal saved 〈def, [ ]〉.
     117
     118definition add_pro_and_epilogue :
     119  ∀globals.list register → list register →
     120  joint_internal_function ERTL globals →
     121  joint_internal_function ERTL globals ≝
     122  λglobals,params,ret_regs,def.
     123  let start_lbl ≝ joint_if_entry … def in
     124  let end_lbl ≝ joint_if_exit … def in
     125  state_run … def (
     126    ! sral ← ertl_fresh_reg … ;
     127    ! srah ← ertl_fresh_reg … ;
     128    ! sregs ← allocate_regs … register_list_set RegisterCalleeSaved ;
     129    ! prologue' ← bcompile … (ertl_fresh_reg …) (prologue … params sral srah sregs) ;
     130    let epilogue' ≝ epilogue … ret_regs sral srah sregs in
     131    ! def' ← state_get … ;
     132    let def'' ≝ insert_prologue … prologue' def' in
     133    return insert_epilogue … epilogue' def''
     134  ).
     135
     136definition set_params_hdw :
     137  ∀globals.list psd_argument → list (joint_seq ERTL globals) ≝
     138  λglobals,params.
     139  restore_hdws globals (zip_pottier ? ? params RegisterParams).
     140
     141(* Paolo: The following can probably be done way more efficiently with INC DPTR *)
     142
     143definition set_param_stack :
     144  ∀globals.register → register → psd_argument →
     145  list (joint_seq ERTL globals) ≝
     146  λglobals,addr1,addr2,arg.
     147  [ STORE … addr1 addr2 arg ;
     148    addr1 ← addr1 .Add. (int_size : Byte) ;
     149    addr2 ← addr2 .Addc. zero_byte
     150  ].
     151
     152definition set_params_stack :
     153  ∀globals.list psd_argument → bind_new (localsT ERTL) ? ≝
     154  λglobals,params.
     155  νaddr1,addr2 in
     156  let params_length_byte : Byte ≝ bitvector_of_nat ? (|params|) in
     157  [ PSD addr1 ← HDW RegisterSPL ;
     158    PSD addr2 ← HDW RegisterSPH ;
     159    CLEAR_CARRY ?? ;
     160    addr1 ← addr1 .Sub. params_length_byte ;
     161    addr2 ← addr2 .Sub. zero_byte
     162  ] @
     163  flatten … (map … (set_param_stack globals addr1 addr2) params).
    244164
    245165definition set_params ≝
     
    249169  let hdw_params ≝ \fst hdw_stack_params in
    250170  let stack_params ≝ \snd hdw_stack_params in
    251     set_params_hdw globals hdw_params @ set_params_stack globals stack_params.
    252 
    253 definition fetch_result ≝
    254   λglobals.
    255   λret_regs.
    256   λstart_lbl: label.
    257   match reduce_strong ? ? RegisterSTS RegisterRets with
    258   [ mk_Sig crl first_crl_proof ⇒
     171  set_params_hdw globals hdw_params @@ set_params_stack globals stack_params.
     172
     173definition fetch_result :
     174  ∀globals.list register → list (joint_seq ERTL globals) ≝
     175  λglobals,ret_regs.
     176  match reduce_strong ?? RegisterSTS RegisterRets with
     177  [ mk_Sig crl crl_proof ⇒
    259178    let commonl ≝ \fst (\fst crl) in
    260179    let commonr ≝ \fst (\snd crl) in
    261     let f_save ≝ λst. λret. sequential ertl_params_ globals (MOVE … 〈hardware st, hardware ret〉) in
    262     let saves ≝ map2 ? ? ? f_save commonl commonr ? in
    263     match reduce_strong ? ? ret_regs RegisterSTS with
    264     [ mk_Sig crl second_crl_proof ⇒
     180    map2 … (λst,r.HDW st ← HDW r) commonl commonr crl_proof @
     181    match reduce_strong ?? ret_regs RegisterSTS with
     182    [ mk_Sig crl crl_proof ⇒
    265183      let commonl ≝ \fst (\fst crl) in
    266184      let commonr ≝ \fst (\snd crl) in
    267       let f_restore ≝ λr. λst. sequential ertl_params_ … (MOVE … 〈pseudo r, hardware st〉) in
    268       let restores ≝ map2 ? ? ? f_restore commonl commonr ? in
    269         adds_graph ertl_params1 … (saves @ restores) start_lbl]].
    270 [@second_crl_proof | @first_crl_proof]
    271 qed.
    272 
    273 definition translate_call_id ≝
    274   λglobals,f.
    275   λargs.
    276   λret_regs.
    277   λstart_lbl.
    278   λdest_lbl.
    279   λdef.
    280   let nb_args ≝ |args| in
    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
     185      map2 … (λret,st.PSD ret ← HDW st) commonl commonr crl_proof
     186    ]
     187  ].
     188
     189definition translate_step :
     190  ∀globals.label → joint_step RTL_ntc globals →
     191    bind_seq_block ERTL globals (joint_step ERTL globals) ≝
     192  λglobals.λ_.λs.
     193  match s return λ_.bind_seq_block ?? (joint_step ??) with
     194  [ step_seq s ⇒
     195    match s return λ_.bind_seq_block ?? (joint_step ??) with
     196    [ PUSH _ ⇒ NOOP … (*CSC: XXXX should not be in the syntax *)
     197    | POP _ ⇒ NOOP …  (*CSC: XXXX should not be in the syntax *)
     198    | MOVE rs ⇒ PSD (\fst rs) ← \snd rs
     199    | COST_LABEL lbl ⇒
     200      COST_LABEL … lbl
     201    | ADDRESS x prf r1 r2 ⇒
     202      ADDRESS ERTL ? x prf r1 r2
     203    | OPACCS op destr1 destr2 srcr1 srcr2 ⇒
     204      OPACCS ERTL ? op destr1 destr2 srcr1 srcr2 
     205    | OP1 op1 destr srcr ⇒
     206      OP1 ERTL ? op1 destr srcr
     207    | OP2 op2 destr srcr1 srcr2 ⇒
     208      OP2 ERTL ? op2 destr srcr1 srcr2
     209    | CLEAR_CARRY ⇒
     210      CLEAR_CARRY …
     211    | SET_CARRY ⇒
     212      SET_CARRY …
     213    | LOAD destr addr1 addr2 ⇒
     214      LOAD ERTL ? destr addr1 addr2
     215    | STORE addr1 addr2 srcr ⇒
     216      STORE ERTL ? addr1 addr2 srcr
     217    | COMMENT msg ⇒
     218      COMMENT … msg
     219    | extension_seq ext ⇒
     220      match ext with
     221      [ rtl_stack_address addr1 addr2 ⇒
     222        [ PSD addr1 ← HDW RegisterSPL ; PSD addr2 ← HDW RegisterSPH ]
    285223      ]
    286     ) start_lbl dest_lbl def.
    287 
    288 definition translate_stmt :
    289  ∀globals: list ident. label → rtlntc_statement globals → ertl_internal_function globals → ertl_internal_function globals
    290  ≝
    291   λglobals.
    292   λlbl.
    293   λstmt.
    294   λdef.
    295   match stmt with
    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_stack_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 *)
    342 qed.
     224    | CALL_ID f args ret_regs ⇒
     225      set_params ? args @@
     226      CALL_ID ERTL ? f (|args|) it :::
     227      fetch_result ? ret_regs
     228    | extension_call c ⇒
     229      match c with
     230      [ rtl_call_ptr f1 f2 args dest ⇒
     231        ?
     232      ]
     233    ]
     234  | COND r ltrue ⇒
     235    COND ERTL ? r ltrue
     236  ]. cases daemon (* pointer call to be ported yet *) qed.
     237
     238definition translate_fin_step :
     239  ∀globals.label → joint_fin_step RTL_ntc →
     240    bind_seq_block ERTL globals (joint_fin_step ERTL) ≝
     241  λglobals.λ_.λs.
     242  match s with
     243  [ GOTO lbl' ⇒ GOTO … lbl'
     244  | RETURN ⇒ RETURN ?
     245  | tailcall abs ⇒ match abs in void with [ ]
     246  ].
    343247
    344248(* hack with empty graphs used here *)
    345 definition translate_funct_internal ≝
    346   λglobals.λdef:rtlntc_internal_function globals.
     249definition translate_funct :
     250  ∀globals.joint_internal_function RTL_ntc globals →
     251    joint_internal_function ERTL globals ≝
     252  λglobals,def.
    347253  let nb_params ≝ |joint_if_params ?? def| in
    348254  let added_stacksize ≝ max 0 (minus nb_params (|RegisterParams|)) in
    349255  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
    354   let def' ≝
    355     mk_joint_internal_function globals (ertl_params globals)
    356       (joint_if_luniverse … def) (joint_if_runiverse … def) (joint_if_result … def) (*CSC: different from OCaml code where joint_if_result is unit*)
     256  let entry' ≝ pi1 … (joint_if_entry … def) in
     257  let exit' ≝ pi1 … (joint_if_exit … def) in
     258  let def' ≝ init_graph_if ERTL globals
     259      (joint_if_luniverse … def) (joint_if_runiverse … def) it (*Paolo: to be checked, unit or list register? *)
    357260      nb_params new_locals ((joint_if_stacksize … def) + added_stacksize)
    358       graph' ? ? in
    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'.
    361 whd 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 ]
    366 qed.
    367 
     261      entry' exit' in
     262  let def'' ≝ b_graph_translate …
     263    (ertl_fresh_reg …)
     264    def'
     265    (translate_step globals)
     266    (translate_fin_step globals)
     267    def in
     268  add_pro_and_epilogue ? (joint_if_params ?? def) (joint_if_result ?? def) def'.
     269
     270(* removing this because of how insert_prologue is now defined
    368271definition generate ≝
    369272  λglobals.
    370273  λstmt.
    371   λdef: joint_internal_function … (ertl_params globals).
     274  λdef: joint_internal_function globals ERTL.
    372275  let 〈entry, def〉 ≝ fresh_label … def in
    373276  let graph ≝ add … (joint_if_code … def) entry stmt in
    374    set_joint_if_graph … (ertl_params globals) graph def ??.
     277   set_joint_if_graph … (ERTL globals) graph def ??.
    375278  [ (*% [ @entry | @graph_add ]*) cases daemon (*CSC: XXX *)
    376279  | (*cases (joint_if_exit … def) #LBL #LBL_PRF % [ @LBL | @graph_add_lookup @LBL_PRF
     
    392295         match inst with
    393296          [ COST_LABEL cost_lbl ⇒
    394              〈Some … cost_lbl, add_graph ertl_params1 globals lbl (GOTO … lbl) def〉
     297             〈Some … cost_lbl, add_graph ERTL1 globals lbl (GOTO … lbl) def〉
    395298          | _ ⇒ find_and_remove_first_cost_label_internal globals def lbl num_nodes' ]
    396299      | RETURN ⇒ 〈None …, def〉
     
    407310  match cost_label with
    408311  [ None ⇒ def
    409   | Some cost_label ⇒ generate … (sequential ertl_params_ globals (COST_LABEL … cost_label) (joint_if_entry … def)) def
     312  | Some cost_label ⇒ generate … (sequential ERTL_ globals (COST_LABEL … cost_label) (joint_if_entry … def)) def
    410313  ].
    411314
    412315definition translate_funct ≝ λglobals,def. (move_first_cost_label_up_internal … (translate_funct_internal globals def)).
     316*)
    413317
    414318definition rtl_to_ertl : rtl_program → ertl_program ≝
  • src/RTL/semantics.ma

    r2176 r2286  
    66record frame: Type[0] ≝
    77 { fr_ret_regs: list register
    8  ; fr_pc: address
    9  ; fr_sp: pointer
    10  ; fr_carry: beval
     8 ; fr_pc: cpointer
     9 ; fr_sp: xpointer
     10 ; fr_carry: bebit
    1111 ; fr_regs: register_env beval
    1212 }.
    1313
    14 definition rtl_more_sem_params: more_sem_params rtl_params_ :=
    15  mk_more_sem_params rtl_params_
    16   (list frame) [] (register_env beval) (λ_.empty_map …) [] [](*dummy*)
    17    reg_store reg_retrieve reg_store reg_retrieve reg_store reg_retrieve
    18     reg_store reg_retrieve reg_store reg_retrieve
    19      (λlocals,dest_src.
    20        do v ← reg_retrieve locals (\snd dest_src) ;
    21        reg_store (\fst dest_src) v locals).
    22 definition rtl_sem_params: sem_params ≝ mk_sem_params … rtl_more_sem_params.
    23 
    24 definition rtl_init_locals :
    25  list register → register_env beval → register_env beval ≝
    26  λlocals,env.
    27   foldl ?? (λlenv,reg. add … lenv reg BVundef) env locals.
     14definition RTL_state : sem_state_params ≝
     15  mk_sem_state_params
     16    (list frame)
     17    [ ]
     18    (register_env beval)
     19    (λ_.empty_map …).
     20
     21definition rtl_arg_retrieve : ?→?→res ? ≝ λenv.λa : psd_argument.
     22  match a with
     23  [ Reg r ⇒ reg_retrieve env r
     24  | Imm b ⇒ return b
     25  ].
    2826
    2927(*CSC: could we use here a dependent type to avoid the Error case? *)
     
    3230
    3331definition rtl_fetch_ra:
    34  state … rtl_sem_params → res ((state … rtl_sem_params) × address) ≝
     32 RTL_state → res (RTL_state × cpointer) ≝
    3533 λst.
    3634  match st_frms ? st with
     
    3836  | cons hd tl ⇒ OK … 〈st, fr_pc hd〉 ].
    3937
    40 definition rtl_result_regs:
    41  ∀globals. genv … (rtl_params globals) → state rtl_sem_params → res (list register) ≝
    42  λglobals,ge,st.
    43   do fn ← graph_fetch_function … globals ge st ;
    44   OK … (joint_if_result … fn).
    45 
    46 (*CSC: we could use a dependent type here: the list of return values should have
    47   the same length of the list of return registers that store the values. This
    48   saves the OutOfBounds exception *)
    49 definition rtl_pop_frame:
    50  ∀globals. genv … (rtl_params globals) → state … rtl_sem_params → res (state … rtl_sem_params) ≝
    51  λglobals,ge,st.
    52   do ret_regs ← rtl_result_regs … ge st ;
    53   do ret_vals ← mmap … (λreg.greg_retrieve rtl_sem_params st reg) ret_regs ;
    54   match st_frms ? st with
    55   [ nil ⇒ Error ? [MSG EmptyStack]
    56   | cons hd tl ⇒
    57      do st ←
    58       mfold_left_i ??
    59        (λi.λst.λreg.
    60          do v ← opt_to_res ? [MSG OutOfBounds] (nth_opt … i ret_vals) ;
    61          greg_store rtl_sem_params reg v st)
    62        (OK … st) (fr_ret_regs hd) ;
    63      OK …
    64       (set_frms rtl_sem_params tl
    65         (set_regs rtl_sem_params (fr_regs hd)
    66          (set_sp … (fr_sp hd)
    67           (set_carry … (fr_carry hd)
    68            (set_m … (free … (m … st) (pblock (sp … st))) st)))))].
    69 
    70 definition rtl_call_function:
    71  nat → list register → list register → state … rtl_sem_params → res (state … rtl_sem_params) ≝
     38definition rtl_init_local :
     39 register → register_env beval → register_env beval ≝
     40 λlocal,env.add … env local BVundef.
     41
     42definition rtl_setup_call:
     43 nat → list register → list psd_argument → RTL_state → res RTL_state ≝
    7244  λstacksize,formal_arg_regs,actual_arg_regs,st.
    7345  let 〈mem,b〉 ≝ alloc … (m … st) 0 stacksize XData in
     
    7547   mfold_left2 …
    7648    (λlenv,dest,src.
    77       do v ← greg_retrieve … st src ;
     49      do v ← rtl_arg_retrieve … (regs ? st) src ;
    7850      OK … (add … lenv dest v))
    7951    (OK … (empty_map …)) formal_arg_regs actual_arg_regs ;
    8052  OK …
    81    (set_regs rtl_sem_params new_regs
     53   (set_regs RTL_state new_regs
    8254    (set_m … mem
    83      (set_sp … (mk_pointer b (mk_offset 0)) st))).
    84 (*cases b * #r #off #E >E %
    85 qed.*)
    86 
    87 definition rtl_save_frame:
    88  address → nat → list register → list register → list register → state … rtl_sem_params → res (state … rtl_sem_params) ≝
    89  λl,stacksize,formal_arg_regs,actual_arg_regs,retregs,st.
    90   let frame ≝ mk_frame retregs l (sp … st) (carry … st) (regs … st) :: (st_frms … st) in
    91   let st ≝ set_frms rtl_sem_params frame st in
    92   rtl_call_function stacksize formal_arg_regs actual_arg_regs st.
     55     (set_sp … (mk_pointer b (mk_offset (bv_zero …))) st))).
     56cases b * #r #off #E >E %
     57qed.
     58
     59definition rtl_save_frame ≝ λl.λretregs.λst : RTL_state.
     60  let frame ≝ mk_frame retregs l (sp … st) (carry … st) (regs ? st) :: (st_frms … st) in
     61  OK … (set_frms RTL_state frame st).
    9362
    9463(*CSC: XXXX, for external functions only*)
    95 axiom rtl_fetch_external_args: external_function → state rtl_sem_params → res (list val).
    96 axiom rtl_set_result: list val → state rtl_sem_params → res (state rtl_sem_params).
    97 
    98 definition rtl_more_sem_params1: ∀globals. more_sem_params1 … (rtl_params globals) ≝
    99  λglobals.
    100   mk_more_sem_params1 … rtl_more_sem_params graph_succ_p (graph_pointer_of_label …)
    101    (graph_fetch_statement …) rtl_fetch_ra (rtl_result_regs …)
    102    rtl_init_locals rtl_save_frame (rtl_pop_frame …)
    103    rtl_fetch_external_args rtl_set_result.
    104 definition rtl_sem_params1: ∀globals. sem_params1 … globals ≝
    105  λglobals. mk_sem_params1 … (rtl_more_sem_params1 globals).
    106 
    107 definition block_of_register_pair: register → register → state rtl_sem_params → res block ≝
    108  λr1,r2,st.
    109  do v1 ← greg_retrieve rtl_sem_params st r1 ;
    110  do v2 ← greg_retrieve rtl_sem_params st r2 ;
    111  do ptr ← pointer_of_address 〈v1,v2〉 ;
    112  OK … (pblock ptr). 
     64axiom rtl_fetch_external_args: external_function → RTL_state → res (list val).
     65axiom rtl_set_result: list val → list register → RTL_state → res RTL_state.
     66
     67definition rtl_reg_store ≝ λr,v,st.! mem ← reg_store r v (regs RTL_state st) ; return set_regs RTL_state mem st.
     68definition rtl_reg_retrieve ≝ λst.reg_retrieve (regs RTL_state st).
     69
     70definition rtl_read_result :
     71 ∀globals.genv RTL globals → list register → RTL_state → res (list beval) ≝
     72 λglobals,ge,rets,st.
     73 m_list_map … (rtl_reg_retrieve st) rets.
     74
     75(*CSC: we could use a dependent type here: the list of return values should have
     76  the same length of the list of return registers that store the values. This
     77  saves the OutOfBounds exception *)
     78definition rtl_pop_frame:
     79 ∀globals. genv RTL globals → joint_internal_function RTL globals → RTL_state →
     80  res RTL_state ≝
     81 λglobals,ge,curr_fn,st.
     82  let ret ≝ joint_if_result … curr_fn in
     83  do ret_vals ← rtl_read_result … ge ret st ;
     84  match st_frms ? st with
     85  [ nil ⇒ Error ? [MSG EmptyStack]
     86  | cons hd tl ⇒
     87     do st ←
     88      mfold_left_i …
     89       (λi.λst.λreg.
     90         do v ← opt_to_res ? [MSG OutOfBounds] (nth_opt … i ret_vals) ;
     91         rtl_reg_store reg v st)
     92       (OK … st) (fr_ret_regs hd) ;
     93     OK …
     94      (set_frms RTL_state tl
     95        (set_regs RTL_state (fr_regs hd)
     96         (set_sp … (fr_sp hd)
     97          (set_carry … (fr_carry hd)
     98           (set_m … (free … (m … st) (pblock (sp … st))) st)))))].
    11399
    114100(* This code is quite similar to eval_call_block: can we factorize it out? *)
    115 definition eval_tail_call_block:
    116  ∀globals.genv … (rtl_params globals) → state rtl_sem_params →
    117   block → call_args rtl_sem_params → IO io_out io_in (trace×(state rtl_sem_params)) ≝
    118  λglobals,ge,st,b,args.
    119   ! fd ← opt_to_res … [MSG BadPointer] (find_funct_ptr … ge b);
     101definition eval_tailcall_block:
     102 ∀globals.genv RTL globals → RTL_state →
     103  block → call_args RTL →
     104  (* this is where the result of the current function should be stored *)
     105  call_dest RTL →
     106  IO io_out io_in
     107    ((fin_step_flow RTL (joint_internal_function RTL globals) Call)×RTL_state) ≝
     108 λglobals,ge,st,b,args,ret.
     109  ! fd ← (opt_to_res ? [MSG BadPointer] (find_funct_ptr ? ge b) : IO ? io_in ?);
    120110    match fd with
    121     [ Internal fn ⇒
    122       let st ≝ set_m … (free … (m … st) (pblock (sp … st))) st in
    123       ! st ← rtl_call_function (joint_if_stacksize … fn) (joint_if_params … fn) args st ;
    124       let regs ≝ rtl_init_locals … (joint_if_locals … fn) (regs … st) in
    125       let l' ≝ joint_if_entry … fn in
    126       ! st ← next … (rtl_sem_params1 …) l' (set_regs rtl_sem_params regs st) ;
    127        return 〈 E0, st〉
    128     | External fn ⇒ ?(*
    129       ! params ← fetch_external_args … fn st;
    130       ! evargs ← check_eventval_list params (sig_args (ef_sig fn));
     111    [ Internal fd ⇒
     112      return 〈FTailInit ?? (block_id b) fd args, st〉
     113    | External fn ⇒
     114      ! params ← rtl_fetch_external_args … fn st : IO ???;
     115      ! evargs ← check_eventval_list params (sig_args (ef_sig fn)) : IO ???;
    131116      ! evres ← do_io (ef_id fn) evargs (proj_sig_res (ef_sig fn));
    132117      (* CSC: XXX bug here; I think I should split it into Byte-long
    133118         components; instead I am making a singleton out of it. To be
    134119         fixed once we fully implement external functions. *)
    135         let vs ≝ [mk_val ? evres] in
    136       ! st ← set_result … vs st;
    137       let st ≝ set_pc … ra st in
    138         ret ? 〈Eextcall (ef_id fn) evargs (mk_eventval ? evres), st〉 *)
    139      ].
    140 cases daemon (*CSC: XXX tailcall to external function not implemented yet;
    141                     it needs alls other functions on external calls *)
    142 qed.
    143 
    144 definition rtl_exec_extended:
    145  ∀globals. genv globals (rtl_params globals) →
    146   rtl_statement_extension → label → state rtl_sem_params →
    147    IO io_out io_in (trace × (state rtl_sem_params)) ≝
    148  λglobals,ge,stm,l,st.
     120      let vs ≝ [mk_val ? evres] in
     121      ! st ← rtl_set_result … vs ret st : IO ???;
     122      return 〈FEnd2 ??, st〉
     123    ].
     124
     125definition block_of_register_pair: register → register → RTL_state → res block ≝
     126 λr1,r2,st.
     127 do v1 ← rtl_reg_retrieve st r1 ;
     128 do v2 ← rtl_reg_retrieve st r2 ;
     129 do ptr ← pointer_of_address 〈v1,v2〉 ;
     130 OK … (pblock ptr). 
     131
     132definition eval_rtl_seq:
     133 ∀globals. genv RTL globals →
     134  rtl_seq → joint_internal_function RTL globals → RTL_state →
     135   IO io_out io_in RTL_state ≝
     136 λglobals,ge,stm,curr_fn,st.
    149137  match stm with
    150    [ rtl_st_ext_stack_address dreg1 dreg2  ⇒
     138   [ rtl_stack_address dreg1 dreg2  ⇒
    151139      let sp ≝ sp ? st in
    152140      ! 〈dpl,dph〉 ← beval_pair_of_pointer sp ;
    153       ! st ← greg_store rtl_sem_params dreg1 dpl st ;
    154       ! st ← greg_store rtl_sem_params dreg2 dph st ;
    155       ! st ← next … (rtl_sem_params1 globals) l st ;
    156        return 〈E0, st〉
    157    | rtl_st_ext_call_ptr r1 r2 args dest ⇒
    158       ! b ← block_of_register_pair r1 r2 st : IO ??? ;
    159       ! ra ← succ_pc … (rtl_more_sem_params1 globals) l (pc … st) : IO ??? ;
    160       eval_call_block … (mk_sem_params1 … (rtl_more_sem_params1 globals))
    161        ge st b args dest ra
    162    | rtl_st_ext_tailcall_id id args ⇒
     141      ! st ← rtl_reg_store dreg1 dpl st ;
     142      rtl_reg_store dreg2 dph st
     143   ].
     144
     145definition eval_rtl_call:
     146 ∀globals. genv RTL globals →
     147  rtl_call → RTL_state →
     148   IO io_out io_in ((step_flow RTL ? Call)×RTL_state) ≝
     149 λglobals,ge,stm,st.
     150  match stm with
     151  [ rtl_call_ptr r1 r2 args dest ⇒
     152    ! b ← block_of_register_pair r1 r2 st : IO ???;
     153    ! fd ← (opt_to_res ? [MSG BadPointer] (find_funct_ptr ? ge b) : IO ? io_in ?);
     154    match fd with
     155    [ Internal fd ⇒
     156      return 〈Init ?? (block_id b) fd args dest, st〉
     157    | External fn ⇒
     158      ! params ← rtl_fetch_external_args … fn st : IO ???;
     159      ! evargs ← check_eventval_list params (sig_args (ef_sig fn)) : IO ???;
     160      ! evres ← do_io (ef_id fn) evargs (proj_sig_res (ef_sig fn));
     161      (* CSC: XXX bug here; I think I should split it into Byte-long
     162         components; instead I am making a singleton out of it. To be
     163         fixed once we fully implement external functions. *)
     164      let vs ≝ [mk_val ? evres] in
     165      ! st ← rtl_set_result … vs dest st : IO ???;
     166      return 〈Proceed ???, st〉
     167    ]
     168  ].
     169
     170definition eval_rtl_tailcall:
     171 ∀globals. genv RTL globals →
     172  rtl_tailcall → joint_internal_function RTL globals → RTL_state →
     173   IO io_out io_in ((fin_step_flow RTL ? Call)×RTL_state) ≝
     174   λglobals,ge,stm,curr_fn,st.
     175   let ret ≝ joint_if_result … curr_fn in
     176   match stm with
     177   [ rtl_tailcall_id id args ⇒
    163178      ! b ← opt_to_res … [MSG MissingSymbol; CTX ? id] (find_symbol … ge id) : IO ???;
    164       eval_tail_call_block … ge st b args
    165    | rtl_st_ext_tailcall_ptr r1 r2 args ⇒
     179      eval_tailcall_block … ge st b args ret
     180   | rtl_tailcall_ptr r1 r2 args ⇒
    166181      ! b ← block_of_register_pair r1 r2 st : IO ???;
    167       eval_tail_call_block … ge st b args
     182      eval_tailcall_block … ge st b args ret
    168183   ].
    169184
    170 definition rtl_more_sem_params2: ∀globals. more_sem_params2 … (rtl_params globals) ≝
    171  λglobals. mk_more_sem_params2 … (rtl_more_sem_params1 globals) (rtl_exec_extended …).
    172 
    173 definition rtl_fullexec ≝
    174  joint_fullexec … (λp. rtl_more_sem_params2 (prog_var_names … p)).
     185definition RTL_semantics ≝
     186  make_sem_graph_params RTL
     187    (mk_more_sem_unserialized_params ??
     188      RTL_state
     189      reg_store reg_retrieve rtl_arg_retrieve
     190      reg_store reg_retrieve rtl_arg_retrieve
     191      reg_store reg_retrieve rtl_arg_retrieve
     192      reg_store reg_retrieve rtl_arg_retrieve
     193      rtl_arg_retrieve
     194      (λenv,p. let 〈dest,src〉 ≝ p in
     195        ! v ← rtl_arg_retrieve env src ;
     196        reg_store dest v env)
     197      rtl_fetch_ra
     198      rtl_init_local
     199      rtl_save_frame
     200      rtl_setup_call
     201      rtl_fetch_external_args
     202      rtl_set_result
     203      [ ] [ ]
     204      rtl_read_result
     205      eval_rtl_seq
     206      eval_rtl_tailcall
     207      eval_rtl_call
     208      rtl_pop_frame
     209      (λ_.λ_.λ_.λ_.λ_.λ_.λst.st)).
  • src/RTLabs/RTLabsToRTL.ma

    r2176 r2286  
    55include "common/Graphs.ma".
    66include "joint/TranslateUtils.ma".
     7include "utilities/bindLists.ma".
    78include alias "ASM/BitVector.ma".
    89include alias "arithmetics/nat.ma".
    910
    10 let rec register_freshes (runiverse: universe RegisterTag) (n: nat) on n ≝
    11   match n with
    12   [ O ⇒ 〈[],runiverse〉
    13   | S n' ⇒
    14      let 〈r,runiverse〉 ≝ fresh … runiverse in
    15      let 〈res,runiverse〉 ≝ register_freshes runiverse n' in
    16       〈r::res,runiverse〉 ].
    17 
    18 definition complete_regs ≝
    19   λglobals.
    20   λdef.
    21   λsrcrs1.
    22   λsrcrs2.
    23   if leb (length … srcrs2) (length … srcrs1) then
    24    let 〈def, added_regs〉 ≝ fresh_regs rtl_params0 globals def (minus (length ? srcrs1) (length ? srcrs2)) in
    25     〈〈srcrs1, srcrs2 @ added_regs〉, added_regs〉
    26   else
    27    let 〈def, added_regs〉 ≝ fresh_regs rtl_params0 globals def (minus (length ? srcrs2) (length ? srcrs1)) in
    28     〈〈srcrs1 @ added_regs, srcrs2〉, added_regs〉.
    29 
    30 lemma complete_regs_length:
    31   ∀globals,def,left,right.
    32    |\fst (\fst (complete_regs globals def left right))| = |\snd (\fst (complete_regs globals def left right))|.
    33  #globals #def #left #right
    34  whd in match complete_regs; normalize nodelta
    35  @leb_elim normalize nodelta #H
    36  [ generalize in match (fresh_regs_length rtl_params0 globals def (minus (length … left) (length … right)));
    37  | generalize in match (fresh_regs_length rtl_params0 globals def (minus (length … right) (length … left)));]
    38  cases (fresh_regs ????) #def' #fresh normalize >append_length
    39  generalize in match H; -H;
    40  generalize in match (length … left); generalize in match (length … right); generalize in match (length … fresh);
    41  [ /2/ | #x #y #z #H generalize in match (not_le_to_lt … H); -H #H #E >E >commutative_plus
    42          <plus_minus_m_m /2/ ]
    43 qed.
     11definition rtl_fresh_reg:
     12 ∀globals.freshT RTL globals register ≝
     13  λglobals,def.
     14    let 〈r, runiverse〉 ≝ fresh … (joint_if_runiverse … def) in
     15    〈set_locals ?? (set_runiverse ?? def runiverse)(r::joint_if_locals ?? def), r〉.
     16
     17definition rtl_fresh_reg_no_local :
     18 ∀globals.freshT RTL globals register ≝
     19  λglobals,def.
     20    let 〈r, runiverse〉 ≝ fresh … (joint_if_runiverse … def) in
     21    〈set_runiverse ?? def runiverse, r〉.
    4422
    4523definition size_of_sig_type ≝
     
    4725  match sig with
    4826  [ ASTint isize sign ⇒
    49     let isize' ≝ match isize with [ I8 ⇒ 8 | I16 ⇒ 16 | I32 ⇒ 32 ] in
    50       isize' ÷ (nat_of_bitvector ? int_size)
     27    match isize with [ I8 ⇒ 1 | I16 ⇒ 2 | I32 ⇒ 4 ]
    5128  | ASTfloat _ ⇒ ? (* dpm: not implemented *)
    52   | ASTptr ⇒ nat_of_bitvector ? ptr_size
    53   ].
    54   cases not_implemented;
     29  | ASTptr ⇒ 2 (* rgn ⇒ nat_of_bitvector ? ptr_size *)
     30  ].
     31  cases not_implemented
    5532qed.
    5633
     
    6138definition local_env ≝ identifier_map RegisterTag (list register).
    6239
    63 definition mem_local_env : register → local_env → bool ≝
    64   λr,e. member … e r.
    65 
    66 definition add_local_env : register → list register → local_env → local_env ≝
    67   λr,v,e. add … e r v.
    68 
    69 definition find_local_env : register → local_env → list register ≝
    70   λr: register.λenv. lookup_def … env r [].
    71 
    72 definition initialize_local_env_internal ≝
    73   λlenv_runiverse.
    74   λr_sig.
    75   let 〈lenv,runiverse〉 ≝ lenv_runiverse in
     40definition local_env_typed :
     41  list (register × typ) → local_env → Prop ≝
     42  λl,env.All ?
     43    (λp.let 〈r, ty〉 ≝ p in ∃regs.lookup … env r = Some ? regs ∧
     44                                 |regs| = size_of_sig_type ty) l.
     45
     46definition find_local_env ≝ λr.λlenv : local_env.
     47  λprf : r ∈ lenv.opt_safe … (lookup … lenv r) ?.
     48lapply (in_map_domain … lenv r)
     49>prf * #x #lookup_eq >lookup_eq % #ABS destruct(ABS)
     50qed.
     51
     52lemma find_local_env_elim : ∀P : list register → Prop.∀r. ∀lenv: local_env.∀prf.
     53  (∀x.lookup … lenv r = Some ? x → P x) → P (find_local_env r lenv prf).
     54#P#r#lenv#prf #H
     55change with (P (opt_safe ???))
     56@opt_safe_elim assumption
     57qed.
     58
     59definition find_local_env_arg : register → local_env → ? → list psd_argument ≝
     60  λr,lenv,prf. map … (Reg ?) (find_local_env r lenv prf).
     61
     62definition initialize_local_env_internal :
     63  ∀globals.
     64  ((joint_internal_function RTL globals) × local_env) → (register×typ) →
     65  ((joint_internal_function RTL globals) × local_env) ≝
     66  λglobals,def_env,r_sig.
     67  let 〈def,lenv〉 ≝ def_env in
    7668  let 〈r, sig〉 ≝ r_sig in
    7769  let size ≝ size_of_sig_type sig in
    78   let 〈rs,runiverse〉 ≝ register_freshes runiverse size in
    79     〈add_local_env r rs lenv,runiverse〉.
    80 
    81 definition initialize_local_env ≝
    82   λruniverse.
    83   λregisters.
    84   λresult.
    85   let registers ≝ registers @
    86     match result with
    87     [ None ⇒ [ ]
    88     | Some rt ⇒ [ rt ]
     70  let 〈def,rs〉 ≝ repeat_fresh … (rtl_fresh_reg_no_local globals) size def in
     71    〈def,add … lenv r rs〉.
     72
     73include alias "common/Identifiers.ma".
     74let rec map_list_local_env
     75  lenv (regs : list (register×typ)) on regs :
     76  All ? (λpr.bool_to_Prop (\fst pr ∈ lenv)) regs → list register ≝
     77  match regs return λx.All ?? x → ? with
     78  [ nil ⇒ λ_.[ ]
     79  | cons hd tl ⇒ λprf.find_local_env (\fst hd) lenv ? @ map_list_local_env lenv tl ?
     80  ].cases prf #A #B assumption qed.
     81
     82definition initialize_local_env :
     83  ∀globals.
     84  list (register×typ) →
     85  freshT RTL globals local_env ≝
     86  λglobals,registers,def.
     87  foldl ?? (initialize_local_env_internal globals) 〈def,empty_map …〉 registers.
     88
     89lemma initialize_local_env_in : ∀globals,l,def,r.
     90  Exists ? (λx.\fst x = r) l → r ∈ \snd (initialize_local_env globals l def).
     91#globals #l #U #r @(list_elim_left … l)
     92[ *
     93| * #tl #sig #hd #IH #G elim (Exists_append … G) -G
     94  whd in match initialize_local_env; normalize nodelta
     95  >foldl_step change with (initialize_local_env ???) in match (foldl ?????);
     96  [ #H lapply (IH H)
     97  | * [2: *] #EQ destruct(EQ)
     98  ] 
     99  cases (initialize_local_env ???)
     100  #U' #env' [#G] whd in match initialize_local_env_internal; normalize nodelta
     101  elim (repeat_fresh ??????) #U'' #rs
     102  [ >mem_set_add @orb_Prop_r assumption
     103  | @mem_set_add_id
     104  ]
     105qed.
     106
     107example proj1_rewrite : ∀A,B,a,b.∀pr : A×B.〈a,b〉 = pr → a = \fst pr.
     108// qed-.
     109example proj2_rewrite : ∀A,B,a,b.∀pr : A×B.〈a,b〉 = pr → b = \snd pr.
     110// qed-.
     111
     112definition initialize_locals_params_ret :
     113  ∀globals.
     114  (* locals *) list (register×typ) →
     115  (* params *) list (register×typ) →
     116  (* return *) option (register×typ) →
     117  freshT RTL globals local_env ≝
     118  λglobals,locals,params,ret,def.
     119  let 〈def',lenv〉 as EQ ≝
     120    initialize_local_env globals
     121    ((match ret with
     122     [ Some r_sig ⇒ [r_sig]
     123     | None ⇒ [ ]
     124     ]) @ locals @ params) def in
     125  let locals' ≝ map_list_local_env lenv locals ? in
     126  let params' ≝ map_list_local_env lenv params ? in
     127  let ret' ≝ match ret return λx.ret = x → ? with
     128    [ Some r_sig ⇒ λprf.find_local_env (\fst r_sig) lenv ?
     129    | None ⇒ λ_.[ ]
     130    ] (refl …) in
     131  let def'' ≝
     132    mk_joint_internal_function RTL globals
     133      (joint_if_luniverse … def') (joint_if_runiverse … def') ret'
     134      params' locals' (joint_if_stacksize … def')
     135      (joint_if_code … def') (joint_if_entry … def') (joint_if_exit … def') in
     136   〈def'', lenv〉. @hide_prf
     137[ >(proj2_rewrite ????? EQ)
     138  @initialize_local_env_in >prf %1 %
     139|*: >(proj2_rewrite ????? EQ)
     140  @(All_mp ??? (λpr.initialize_local_env_in ??? (\fst pr)))
     141  [ @(All_mp … (λpr.Exists ? (λx.\fst x = \fst pr) params))
     142    [ #a #H @Exists_append_r @Exists_append_r @H
     143    | generalize in match params;
    89144    ]
    90   in
    91     foldl … initialize_local_env_internal 〈empty_map …,runiverse〉 registers.
    92 
    93 definition map_list_local_env_internal ≝
    94   λlenv,res,r. res @ (find_local_env r lenv).
    95    
    96 definition map_list_local_env ≝
    97   λlenv,regs. foldl … (map_list_local_env_internal lenv) [ ] regs.
     145  | @(All_mp … (λpr.Exists ? (λx.\fst x = \fst pr) locals))
     146    [ #a #H @Exists_append_r @Exists_append_l @H
     147    | generalize in match locals;
     148    ]
     149  ]
     150  #l elim l [1,3: %] #hd #tl #IH % [1,3: %1 %] @(All_mp … IH) #x #G %2{G}
     151]
     152qed.
    98153
    99154definition make_addr ≝
    100155  λA.
    101156  λlst: list A.
    102   λprf: 2 = length A lst.
    103   match lst return λx. 2 = |x| → A × A with
    104   [ nil ⇒ λlst_nil_prf. ?
    105   | cons hd tl ⇒ λprf.
    106     match tl return λx. 1 = |x| → A × A with
    107     [ nil ⇒ λtl_nil_prf. ?
    108     | cons hd' tl' ⇒ λtl_cons_prf. 〈hd, hd'〉
    109     ] ?
    110   ] prf.
    111   [1: normalize in lst_nil_prf;
    112       destruct(lst_nil_prf)
    113   |2: normalize in prf;
    114       @injective_S
    115       assumption
    116   |3: normalize in tl_nil_prf;
    117       destruct(tl_nil_prf)
    118   ]
    119 qed.
     157  λprf: 2 = length A lst.〈nth_safe … 0 lst ?, nth_safe … 1 lst ?〉. <prf //
     158  qed.
    120159
    121160definition find_and_addr ≝
    122   λr,lenv. make_addr ? (find_local_env r lenv).
    123 
    124 definition rtl_args ≝
    125   λregs_list,lenv. flatten … (map … (λr. find_local_env r lenv) regs_list).
    126 
    127 definition translate_cst_int_internal ≝
    128   λglobals,dest_lbl,r,i. sequential rtl_params_ globals (INT … r i) dest_lbl.
     161  λr,lenv,prf. make_addr ? (find_local_env r lenv prf).
     162
     163include alias "common/Identifiers.ma".
     164let rec rtl_args (args : list register) (env : local_env) on args :
     165  All ? (λr.bool_to_Prop (r∈env)) args → list psd_argument ≝
     166  match args return λx.All ?? x → ? with
     167  [ nil ⇒ λ_.[ ]
     168  | cons hd tl ⇒ λprf.find_local_env_arg hd env ? @ rtl_args tl env ?
     169  ].
     170  cases prf #H #G assumption
     171  qed.
     172
     173include alias "basics/lists/list.ma".
     174let rec vrsplit A (m,n : nat)
     175  on m : Vector A (m*n) → Σs : list (Vector A n).|s| = m ≝
     176  match m return λx.Vector A (x*n) → Sig (list ?) ? with
     177  [ O ⇒ λv.[ ]
     178  | S k ⇒ λv.let spl ≝ vsplit ? n … v in \fst spl :: vrsplit ? k n (\snd spl)
     179  ].
     180  [ %
     181  | cases (vrsplit ????) #lst #EQ normalize >EQ %
     182  ] qed.
    129183
    130184definition split_into_bytes:
    131185  ∀size. ∀int: bvint size. Σbytes: list Byte. |bytes| = size_intsize size ≝
    132 λsize.
    133  match size return λsize.∀int: bvint size. Σbytes. |bytes| = size_intsize size with
    134   [ I8 ⇒ λint. ? | I16 ⇒ λint. ? | I32 ⇒ λint. ? ].
    135 [ %[@[int]] //
    136 | %[@(let 〈h,l〉 ≝ vsplit ? 8 … int in [l;h])] cases (vsplit ????) //
    137 | %[@(let 〈h1,l〉 ≝ vsplit ? 8 … int in
    138       let 〈h2,l〉 ≝ vsplit ? 8 … l in
    139       let 〈h3,l〉 ≝ vsplit ? 8 … l in
    140        [l;h3;h2;h1])]
    141   cases (vsplit ????) #h1 #l normalize
    142   cases (vsplit ????) #h2 #l normalize
    143   cases (vsplit ????) // ]
    144 qed.
    145 
    146 lemma eqb_implies_eq:
    147   ∀m, n: nat.
    148     eqb m n = true → m = n.
    149   #M
    150   elim M
    151   [1: #N normalize
    152       cases N
    153       [1: normalize //
    154       |2: #M' normalize #HYP destruct(HYP)
    155       ]
    156   |2: #M' #IND_HYP #N
    157       normalize
    158       cases N
    159       [1: normalize #HYP destruct(HYP)
    160       |2: #M'' normalize #HYP
    161           @eq_f @(IND_HYP M'')
    162           assumption
    163       ]
    164    ]
    165 qed.
    166 
    167 definition translate_op: ∀globals. ? → list register → list register → list register →
    168   label → label → rtl_internal_function globals → rtl_internal_function globals ≝
     186λsize.vrsplit ? (size_intsize size) 8.
     187
     188let rec list_inject_All_aux A P (l : list A) on l : All A P l → list (Σx.P x) ≝
     189match l return λx.All A P x → ? with
     190[ nil ⇒ λ_.[ ]
     191| cons hd tl ⇒ λprf.«hd, ?» :: list_inject_All_aux A P tl ?
     192]. cases prf #H1 #H2 [@H1 | @H2]
     193qed.
     194
     195include alias "basics/lists/list.ma".
     196definition translate_op:
     197  ∀globals. Op2 →
     198  ∀dests : list register.
     199  ∀srcrs1 : list psd_argument.
     200  ∀srcrs2 : list psd_argument.
     201  |dests| = |srcrs1| → |srcrs1| = |srcrs2| →
     202  list (joint_seq RTL globals)
     203  ≝
    169204  λglobals: list ident.
    170205  λop.
    171   λdestrs: list register.
    172   λsrcrs1: list register.
    173   λsrcrs2: list register.
    174   λstart_lbl: label.
    175   λdest_lbl: label.
    176   λdef: rtl_internal_function globals.
    177   match reduce_strong register register srcrs1 srcrs2 with
    178   [ mk_Sig reduced first_reduced_proof ⇒
    179     let srcrsl_common ≝ \fst (\fst reduced) in
    180     let srcrsr_common ≝ \fst (\snd reduced) in
    181     let srcrsl_rest ≝ \snd (\fst reduced) in
    182     let srcrsr_rest ≝ \snd (\snd reduced) in
    183     let srcrs_rest ≝ srcrsl_rest @ srcrsr_rest in
    184     match reduce_strong register register destrs srcrsl_common with
    185     [ mk_Sig reduced second_reduced_proof ⇒
    186       let destrs_common ≝ \fst (\fst reduced) in
    187       let destrs_rest ≝ \snd (\fst reduced) in
    188       match reduce_strong register register destrs_rest srcrs_rest with
    189       [ mk_Sig reduced third_reduced_proof ⇒
    190         let destrs_cted ≝ \fst (\fst reduced) in
    191         let destrs_rest ≝ \snd (\fst reduced) in
    192         let srcrs_cted ≝ \fst (\snd reduced) in
    193         let 〈def, tmpr〉 ≝ fresh_reg rtl_params0 globals def in
    194         let insts_init ≝ [
    195           sequential … (CLEAR_CARRY …);
    196           sequential … (INT rtl_params_ globals tmpr (zero …))
    197         ] in
    198         let f_add ≝ λdestr. λsrcr1. λsrcr2. sequential … (OP2 rtl_params_ globals op destr srcr1 srcr2) in
    199         let insts_add ≝ map3 ? ? ? ? f_add destrs_common srcrsl_common srcrsr_common ? ? in
    200         let f_add_cted ≝ λdestr. λsrcr. sequential … (OP2 rtl_params_ globals op destr srcr tmpr) in
    201         let insts_add_cted ≝ map2 … f_add_cted destrs_cted srcrs_cted ? in
    202         let f_rest ≝ λdestr. sequential … (OP2 rtl_params_ globals op destr tmpr tmpr) in
    203         let insts_rest ≝ map … f_rest destrs_rest in
    204           adds_graph rtl_params1 globals (insts_init @ insts_add @ insts_add_cted @ insts_rest) start_lbl dest_lbl def
    205       ]
    206     ]
    207   ].
    208   [1: @third_reduced_proof
    209   |3: @first_reduced_proof
    210   |*: cases daemon (* XXX: some of these look like they may be false *)
    211   ]
    212 qed.
    213 
    214 (* Type safety in RTLabs has broken this for the moment...
    215 let rec translate_cst
    216   (globals: list ident) (cst: constant) (destrs: list register)
    217     (start_lbl: label) (dest_lbl: label) (def: rtl_internal_function globals)
    218       on cst: rtl_internal_function globals ≝
    219   match cst with
    220   [ Ointconst size const ⇒
    221     match destrs with
    222     [ nil ⇒ add_graph … start_lbl (GOTO … dest_lbl) def
    223     | _   ⇒
    224       let size' ≝ size_intsize size in
    225         match eqb size' (|destrs|) return λx. (eqb size' (|destrs|)) = x → rtl_internal_function globals with
    226         [ true  ⇒ λgood_case.
    227           match split_into_bytes size const with
    228           [ mk_Sig bytes bytes_length_proof ⇒
    229             let mapped ≝ map2 … (λd. λb. (sequential … (INT rtl_params_ globals d b))) destrs bytes ? in
    230               adds_graph rtl_params1 globals mapped start_lbl dest_lbl def
    231           ]
    232         | false ⇒ λbad_case. ?
    233         ] (refl … (eqb size' (|destrs|)))
    234     ]
    235   | Ofloatconst float ⇒ ⊥
    236   | Oaddrsymbol id offset ⇒
    237     let 〈r1, r2〉 ≝ make_addr … destrs ? in
    238     let def ≝ add_graph rtl_params1 globals start_lbl (sequential … (ADDRESS rtl_params_ globals id ? r1 r2) dest_lbl) def in
    239     let def ≝ translate_op globals Addc [r1] [r1] [r2] start_lbl dest_lbl def in
    240       def
    241   | Oaddrstack offset ⇒
    242     let 〈r1, r2〉 ≝ make_addr … destrs ? in
    243     let def ≝ add_graph rtl_params1 globals start_lbl (sequential … (extension rtl_params_ globals (rtl_st_ext_stack_address r1 r2)) dest_lbl) def in
    244     let def ≝ translate_op globals Addc [r1] [r1] [r2] start_lbl dest_lbl def in
    245       def
    246   ].
    247   [1: >bytes_length_proof
    248       cut(size' = |destrs|)
    249       [1: @eqb_implies_eq
    250           assumption
    251       |2: #EQ_HYP
    252           <EQ_HYP %
    253       ]
    254   |2: cases daemon (* XXX: bad case where destrs is of the wrong length *)
    255   |3: cases not_implemented (* XXX: float, error_float in o'caml *)
    256   |*: cases daemon (* XXX: various proofs to be filled in *)
    257   ].
    258 qed.
    259  
    260 definition translate_move_internal ≝
    261   λglobals.
    262   λdestr: register.
    263   λsrcr: register.
    264     sequential rtl_params_ globals (MOVE … 〈destr,srcr〉).
    265 
    266 definition translate_move ≝
    267   λglobals.
    268   λdestrs: list register.
    269   λsrcrs: list register.
    270   λstart_lbl: label.
    271     match reduce_strong register register destrs srcrs with
    272     [ mk_Sig crl_crr len_proof ⇒
    273       let commonl ≝ \fst (\fst crl_crr) in
    274       let commonr ≝ \fst (\snd crl_crr) in
    275       let restl ≝ \snd (\fst crl_crr) in
    276       let restr ≝ \snd (\snd crl_crr) in
    277       let f_common ≝ translate_move_internal globals in
    278       let translate1 ≝ adds_graph rtl_params1 … (map2 … f_common commonl commonr ?) in
    279       let translate2 ≝ translate_cst … (Ointconst ? (repr I8 0)) restl in (* should this be 8? *)
    280         add_translates … [ translate1 ; translate2 ] start_lbl
    281     ].
    282     @len_proof
    283 qed.
    284 
    285 let rec make
    286   (A: Type[0]) (elt: A) (n: nat) on n ≝
    287   match n with
    288   [ O ⇒ [ ]
    289   | S n' ⇒ elt :: make A elt n'
    290   ].
    291  
    292 lemma make_length:
     206  λdestrs.
     207  λsrcrs1.
     208  λsrcrs2.
     209  λprf1,prf2.
     210  (* first, clear carry if op relies on it *)
     211  match op with
     212  [ Addc ⇒ [CLEAR_CARRY ??]
     213  | Sub ⇒ [CLEAR_CARRY ??]
     214  | _ ⇒ [ ]
     215  ] @ map3 ???? (OP2 RTL globals op) destrs srcrs1 srcrs2 prf1 prf2.
     216
     217definition cast_list : ∀A.A → ℕ → list A → list A ≝
     218λA,deflt,new_length,l.
     219  if leb (|l|) new_length then
     220    l @ make_list ? deflt (new_length - |l|)
     221  else
     222    lhd … l new_length.
     223
     224lemma length_make_list:
    293225  ∀A: Type[0].
    294226  ∀elt: A.
    295227  ∀n: nat.
    296     n = length ? (make A elt n).
     228    length ? (make_list A elt n) = n.
    297229  #A #ELT #N
    298   elim N
    299   [ normalize %
    300   | #N #IH
    301     normalize <IH %
     230  elim N normalize // qed.
     231
     232lemma length_lhd : ∀A,l,n.|lhd A l n| = min (|l|) n.
     233#A #l elim l -l
     234[ * //
     235| #hd #tl #IH * normalize [%]
     236  #n >IH normalize elim (leb ??) %
     237]
     238qed.
     239
     240lemma length_cast_list : ∀A,dflt,n,l.|cast_list A dflt n l| = n.
     241#A #dflt #n #l
     242normalize @leb_elim #H normalize
     243[ >length_append >length_make_list
     244  @sym_eq @minus_to_plus //
     245| >length_lhd normalize @leb_elim
     246  [ #abs elim (absurd ? abs H) ]
     247  #_ %
     248]
     249qed.
     250
     251definition translate_op_asym_unsigned :
     252  ∀globals.Op2 → list register → list psd_argument → list psd_argument →
     253  list (joint_seq RTL globals) ≝
     254  λglobals,op,destrs,srcrs1,srcrs2.
     255  let l ≝ |destrs| in
     256  let srcrs1' ≝ cast_list ? (zero_byte : psd_argument) l srcrs1 in
     257  let srcrs2' ≝ cast_list ? (zero_byte : psd_argument) l srcrs2 in
     258  translate_op globals op destrs srcrs1' srcrs2' ??.
     259  normalize nodelta
     260  >length_cast_list [2: >length_cast_list ] %
     261qed.
     262
     263let rec nat_to_args (size : nat) (k : nat) on size : Σl : list psd_argument.|l| = size ≝
     264match size with
     265[ O ⇒ [ ]
     266| S size' ⇒
     267  (byte_of_nat k : psd_argument) :: nat_to_args size' (k ÷ 8)
     268]. [ % | cases (nat_to_args ??) #res #EQ  normalize >EQ % ] qed.
     269
     270definition size_of_cst ≝ λtyp.λcst : constant typ.match cst with
     271  [ Ointconst size _ _ ⇒ size_intsize size
     272  | Ofloatconst _ _ ⇒ ? (* not implemented *)
     273  | _ ⇒ 2
     274  ].
     275  cases not_implemented qed.
     276
     277definition cst_well_defd : ∀ty.list ident → constant ty → Prop ≝ λty,globals,cst.
     278  match cst with
     279  [ Oaddrsymbol id _ ⇒ member id (eq_identifier ?) globals
     280  | _ ⇒ True
     281  ].
     282
     283definition translate_cst :
     284  ∀ty.
     285  ∀globals: list ident.
     286  ∀cst_sig: Σcst : constant ty.cst_well_defd ty globals cst.
     287  ∀destrs: list register.
     288  |destrs| = size_of_cst ? cst_sig →
     289  list (joint_seq RTL globals)
     290 ≝
     291  λty,globals,cst_sig,destrs.
     292  match pi1 … cst_sig in constant return λty'.λx : constant ty'.
     293      cst_well_defd ty' ? x → |destrs| = size_of_cst ty' x → ?
     294  with
     295  [ Ointconst size sign const ⇒ λcst_prf,prf.
     296      map2 … (λr.λb : Byte.r ← b) destrs
     297        (split_into_bytes size const) ?
     298  | Ofloatconst _ _ ⇒ ?
     299  | Oaddrsymbol id offset ⇒ λcst_prf,prf.
     300    let 〈r1, r2〉 ≝ make_addr … destrs ? in
     301    [ADDRESS RTL globals id ? r1 r2]
     302  | Oaddrstack offset ⇒ λcst_prf,prf.
     303    let 〈r1, r2〉 ≝ make_addr … destrs ? in
     304    [(rtl_stack_address r1 r2 : joint_seq RTL globals)]
     305  ] (pi2 … cst_sig).
     306  [2: cases not_implemented
     307  |1: cases (split_into_bytes ??) #lst
     308    #EQ >EQ >prf whd in ⊢ (??%?); cases size %
     309  |3: @cst_prf
     310  |*: >prf %
    302311  ]
    303312qed.
    304 
    305 definition translate_cast_unsigned ≝
    306   λglobals.
    307   λdestrs.
    308   λstart_lbl.
    309   λdest_lbl.
    310   λdef: joint_internal_function … (rtl_params globals).
    311   let 〈def, tmp_zero〉 ≝ fresh_reg … def in
    312   let zeros ≝ make … tmp_zero (length … destrs) in
    313     add_translates … [
    314       adds_graph rtl_params1 … [
    315         sequential rtl_params_ … (INT rtl_params_ ? tmp_zero (bitvector_of_nat ? 0))
    316         ];
    317       translate_move globals destrs zeros
    318     ] start_lbl dest_lbl def.
    319 
    320 definition translate_cast_signed:
    321     ∀globals: list ident. list register → ? → label → label → rtl_internal_function globals → rtl_internal_function globals ≝
    322   λglobals: list ident.
    323   λdestrs.
    324   λsrcr.
    325   λstart_lbl.
    326   λdest_lbl.
    327   λdef.
    328   let 〈def, tmp_128〉 ≝ fresh_reg … def in
    329   let 〈def, tmp_255〉 ≝ fresh_reg … def in
    330   let 〈def, tmpr〉 ≝ fresh_reg … def in
    331   let 〈def, dummy〉 ≝ fresh_reg … def in
    332   let insts ≝ [
    333     sequential  … (INT rtl_params_ globals tmp_128 (bitvector_of_nat ? 128));
    334     sequential … (OP2 rtl_params_ globals And tmpr tmp_128 srcr);
    335     sequential … (OPACCS rtl_params_ globals DivuModu tmpr dummy tmpr tmp_128);
    336     sequential … (INT rtl_params_ globals tmp_255 (bitvector_of_nat ? 255));
    337     sequential … (OPACCS rtl_params_ globals Mul tmpr dummy tmpr tmp_255)
     313 
     314definition translate_move :
     315  ∀globals.
     316  ∀destrs: list register.
     317  ∀srcrs: list psd_argument.
     318  |destrs| = |srcrs| → list (joint_seq RTL globals) ≝
     319  λglobals,destrs,srcrs,length_eq.
     320  map2 … (λdst,src.dst ← src) destrs srcrs length_eq.
     321
     322definition sign_mask : ∀globals.register → psd_argument →
     323  list (joint_seq RTL globals) ≝
     324    (* this sets destr to 0xFF if s is neg, 0x00 o.w. Done like that:
     325       byte in destr if srcr is: neg   |  pos
     326       destr ← srcr | 127       11...1 | 01...1
     327       destr ← destr <rot< 1    1...11 | 1...10
     328       destr ← INC destr        0....0 | 1....1
     329       destr ← CPL destr        1....1 | 0....0
     330     *)
     331  λglobals,destr,srca.
     332  match srca with
     333  [ Reg srcr ⇒
     334    let byte_127 : Byte ≝ false ::: maximum ? in
     335    [destr ← srcr .Or. byte_127 ;
     336     destr ← .Rl. destr ;
     337     destr ← .Inc. destr ;
     338     destr ← .Cmpl. destr ]
     339  | Imm by ⇒
     340    match by with
     341    [ BVByte b ⇒
     342      if sign_bit … b then
     343        [ destr ← (maximum … : Byte) ]
     344      else
     345        [ destr ← zero_byte ]
     346    | _ ⇒ (* should not happend ... *) [ ]
     347    ]
     348  ].
     349
     350definition translate_cast_signed :
     351  ∀globals : list ident.
     352  list register → psd_argument →
     353  bind_new (localsT RTL) (list (joint_seq RTL globals)) ≝
     354  λglobals,destrs,srca.
     355  ν tmp in
     356  (sign_mask ? tmp srca @
     357  translate_move ? destrs (make_list ? (Reg ? tmp) (|destrs|)) ?).
     358 >length_make_list % qed.
     359
     360definition translate_fill_with_zero :
     361  ∀globals : list ident.
     362  list register → list (joint_seq RTL globals) ≝
     363  λglobals,destrs.
     364  match nat_to_args (|destrs|) 0 with
     365  [ mk_Sig res prf ⇒ translate_move ? destrs res ?].
     366  // qed.
     367
     368let rec last A (l : list A) on l : option A ≝
     369match l with
     370[ nil ⇒ None ?
     371| cons hd tl ⇒
     372  match tl with
     373  [ nil ⇒ Some ? hd
     374  | _ ⇒ last A tl
    338375  ]
    339   in
    340   let srcrs ≝ make … tmpr (length … destrs) in
    341     add_translates rtl_params1 globals [
    342       adds_graph rtl_params1 globals insts;
    343       translate_move globals destrs srcrs
    344     ] start_lbl dest_lbl def.
    345 
    346 definition translate_cast ≝
    347   λglobals: list ident.
    348   λsrc_size: nat.
    349   λsrc_sign: signedness.
    350   λdest_size: nat.
    351   λdestrs: list register.
    352   λsrcrs: list register.
    353   match |srcrs| return λx. |srcrs| = x → ? with
    354   [ O ⇒ λzero_prf. adds_graph rtl_params1 globals [ ]
    355   | S n' ⇒ λsucc_prf.
    356     if ltb dest_size src_size then
    357       translate_move globals destrs srcrs
     376].
     377
     378lemma last_not_empty : ∀A,l.
     379  match l with [ nil ⇒ False | _ ⇒ True ] →
     380  match last A l with
     381  [ None ⇒ False
     382  | _ ⇒ True ].
     383#A #l elim l [ * ]
     384#hd * [ #_ * % ]
     385#hd' #tl #IH * @(IH I)
     386qed.
     387
     388definition translate_op_asym_signed :
     389  ∀globals.Op2 → list register → list psd_argument → list psd_argument →
     390  bind_new (localsT RTL) (list (joint_seq RTL globals)) ≝
     391  λglobals,op,destrs,srcrs1,srcrs2.
     392  νtmp1,tmp2 in
     393  let l ≝ |destrs| in
     394  let f ≝ λsrcrs,tmp.
     395    let srcrs_l ≝ |srcrs| in
     396    if leb srcrs_l l then
     397      match last … srcrs with
     398      [ Some last ⇒
     399        〈srcrs @ make_list … (Reg ? tmp) (l - srcrs_l),
     400         sign_mask … tmp last〉
     401      | None ⇒
     402        〈make_list … (zero_byte : psd_argument) l, [ ]〉
     403      ]
    358404    else
    359       match reduce_strong register register destrs srcrs with
    360       [ mk_Sig crl len_proof ⇒
    361         let commonl ≝ \fst (\fst crl) in
    362         let commonr ≝ \fst (\snd crl) in
    363         let restl ≝ \snd (\fst crl) in
    364         let restr ≝ \snd (\snd crl) in
    365         let insts_common ≝ translate_move globals commonl commonr in
    366         let sign_reg ≝ last_safe ? srcrs ? in
    367         let insts_sign ≝
    368           match src_sign with
    369           [ Unsigned ⇒ translate_cast_unsigned globals restl
    370           | Signed ⇒ translate_cast_signed globals restl sign_reg
    371           ]
    372         in
    373           add_translates rtl_params1 globals [ insts_common; insts_sign ]
     405      〈lhd … srcrs l, [ ]〉 in
     406  let prf : ∀srcrs,tmp.|destrs| = |\fst (f srcrs tmp)| ≝ ? in
     407  let srcrs1init ≝ f srcrs1 tmp1 in
     408  let srcrs2init ≝ f srcrs2 tmp2 in
     409  \snd srcrs1init @ \snd srcrs2init @
     410  translate_op globals op destrs (\fst srcrs1init) (\fst srcrs2init) ??.
     411  [ @prf | <prf @prf ]
     412  #srcrs #tmp normalize nodelta
     413  @leb_elim #H normalize nodelta
     414  [ lapply (last_not_empty … srcrs)
     415    cases (last ??)
     416    [ cases srcrs
     417      [ #_ normalize >length_make_list %
     418      | #hd #tl #abs elim(abs I)
    374419      ]
    375   ] (refl ? (|srcrs|)).
    376   >succ_prf //
    377 qed.
    378 
    379 definition translate_negint ≝
     420    | #last #_ normalize nodelta
     421      >length_append >length_make_list
     422      @minus_to_plus //
     423    ]
     424  | >length_lhd normalize @leb_elim
     425    [ #G elim (absurd … G H)
     426    | #_ %
     427    ]
     428  ]
     429qed.
     430
     431(* using size of lists as size of ints *)
     432definition translate_cast :
     433  ∀globals: list ident.
     434  signedness → list register → list register →
     435    bind_new (localsT RTL) (list (joint_seq RTL globals)) ≝
     436  λglobals,src_sign,destrs,srcrs.
     437  match reduce_strong ?? destrs srcrs with
     438  [ mk_Sig t prf ⇒
     439    let src_common ≝ \fst (\fst t) in
     440    let src_rest   ≝ \snd (\fst t) in
     441    let dst_common ≝ \fst (\snd t) in
     442    let dst_rest   ≝ \snd (\snd t) in
     443    (* first, move the common part *)
     444    translate_move ? src_common (map … (Reg ?) dst_common) ? @@
     445    match src_rest return λ_.bind_new ?? with
     446    [ nil ⇒ (* upcast *)
     447      match src_sign return λ_.bind_new ?? with
     448      [ Unsigned ⇒ translate_fill_with_zero ? dst_rest
     449      | Signed ⇒
     450        match last … srcrs (* = src_common *) with
     451        [ Some src_last ⇒ translate_cast_signed ? dst_rest src_last
     452        | None ⇒ (* srcrs is empty *) translate_fill_with_zero ? dst_rest
     453        ]
     454      ]
     455    | _ ⇒ (* downcast, nothing else to do *) [ ]
     456    ]
     457  ].
     458  >length_map @prf qed.
     459 
     460definition translate_notint :
     461  ∀globals : list ident.
     462  ∀destrs : list register.
     463  ∀srcrs_arg : list register.
     464  |destrs| = |srcrs_arg| → list (joint_seq RTL globals) ≝
     465  λglobals, destrs, srcrs, prf.
     466  map2 ??? (OP1 RTL globals Cmpl) destrs srcrs prf.
     467
     468definition translate_negint : ∀globals.? → ? → ? → bind_new (localsT RTL) (list (joint_seq RTL globals)) ≝
    380469  λglobals: list ident.
    381470  λdestrs: list register.
    382471  λsrcrs: list register.
    383   λstart_lbl: label.
    384   λdest_lbl: label.
    385   λdef: rtl_internal_function globals.
    386472  λprf: |destrs| = |srcrs|. (* assert in caml code *)
    387   let 〈def, tmpr〉 ≝ fresh_reg rtl_params0 globals def in
    388   let f_cmpl ≝ λdestr. λsrcr. sequential rtl_params_ globals (OP1 rtl_params1 globals Cmpl destr srcr) in
    389   let insts_cmpl ≝ map2 … f_cmpl destrs srcrs prf in
    390   let insts_init ≝ [
    391     sequential … (SET_CARRY …);
    392     sequential … (INT rtl_params_ globals tmpr (zero ?))
    393   ] in
    394   let f_add ≝ λdestr. sequential … (OP2 rtl_params_ globals Addc destr destr tmpr) in
    395   let insts_add ≝ map … f_add destrs in
    396     adds_graph rtl_params1 globals (insts_cmpl @ insts_init @ insts_add) start_lbl dest_lbl def.
    397 
    398 definition translate_notbool: ∀globals. list register → list register → label → label → rtl_internal_function globals → rtl_internal_function globals ≝
    399   λglobals: list ident.
    400   λdestrs: list register.
    401   λsrcrs: list register.
    402   λstart_lbl: label.
    403   λdest_lbl: label.
    404   λdef: rtl_internal_function globals.
     473  translate_notint … destrs srcrs prf @
     474  match nat_to_args (|destrs|) 1 with
     475  [ mk_Sig res prf' ⇒
     476    translate_op ? Add destrs (map … (Reg ?) destrs) res ??
     477  ].
     478>length_map // qed.
     479
     480definition translate_notbool:
     481  ∀globals : list ident.
     482  list register → list register →
     483    bind_new (localsT RTL) (list (joint_seq RTL globals)) ≝
     484  λglobals,destrs,srcrs.
    405485  match destrs with
    406   [ nil ⇒ add_graph rtl_params1 globals start_lbl (GOTO … start_lbl) def
    407   | cons destr destrs ⇒
    408     let 〈def, tmpr〉 ≝ fresh_reg rtl_params0 globals def in
    409     let 〈def, tmp_srcrs〉 ≝ fresh_regs rtl_params0 globals def (length ? srcrs) in
    410     let save_srcrs ≝ translate_move globals tmp_srcrs srcrs in
    411     let init_destr ≝ sequential … (INT rtl_params_ globals destr (bitvector_of_nat ? 1)) in
    412     let f ≝ λtmp_srcr. [
    413       sequential … (CLEAR_CARRY rtl_params_ globals);
    414       sequential … (INT rtl_params_ globals tmpr (zero ?));
    415       sequential … (OP2 rtl_params_ globals Sub tmpr tmpr tmp_srcr);
    416       sequential … (INT rtl_params_ globals tmpr (zero ?));
    417       sequential … (OP2 rtl_params_ globals Addc tmpr tmpr tmpr);
    418       sequential … (OP2 rtl_params_ globals Xor destr destr tmpr)
    419     ] in
    420     let insts ≝ init_destr :: (flatten … (map … f tmp_srcrs)) in
    421     let epilogue ≝ translate_cst globals (Ointconst I8 (zero …)) destrs in
    422       add_translates rtl_params1 globals [
    423         save_srcrs; adds_graph rtl_params1 globals insts; epilogue
    424       ] start_lbl dest_lbl def
    425   ].
    426 
    427 (* TODO: examine this properly.  This is a change from the O'caml code due
    428    to us dropping the explicit use of a cast destination size field.  We
    429    instead infer the size of the cast's destination from the context.  Is
    430    this correct?
    431 *)
    432 definition translate_op1 ≝
    433   λglobals: list ident.
     486  [ nil ⇒ [ ]
     487  | cons destr destrs' ⇒
     488    translate_fill_with_zero ? destrs' @@
     489    match srcrs return λ_.bind_new ?? with
     490    [ nil ⇒ [destr ← zero_byte]
     491    | cons srcr srcrs' ⇒
     492      (destr ← srcr) :::
     493      map register (joint_seq RTL globals) (λr. destr ← destr .Or. r) srcrs' @@
     494      (* now destr is non-null iff srcrs was non-null *)
     495      CLEAR_CARRY ?? :::
     496      (* many uses of 0, better not use immediates *)
     497      ν tmp in
     498      [tmp ← zero_byte ;
     499       destr ← tmp .Sub. tmp ;
     500       (* now carry bit is set iff destr was non-null *)
     501       destr ← tmp .Addc. tmp]
     502     ]
     503   ].
     504
     505definition translate_op1 : ∀globals.? → ? → ? → ? → ? → ? → ? →
     506  bind_new (localsT RTL) (list (joint_seq RTL globals)) ≝
     507  λglobals.
    434508  λty, ty'.
    435509  λop1: unary_operation ty ty'.
    436510  λdestrs: list register.
    437511  λsrcrs: list register.
    438   λprf: |destrs| = |srcrs|.
    439   λstart_lbl: label.
    440   λdest_lbl: label.
    441   λdef: rtl_internal_function globals.
    442   match op1 with
    443   [ Ocastint src_size src_sign _ _ ⇒
    444     let dest_size ≝ |destrs| * 8 in
    445     let src_size ≝ bitsize_of_intsize src_size in
    446       translate_cast globals src_size src_sign dest_size destrs srcrs start_lbl dest_lbl def
    447   | Onegint _ _ ⇒
    448       translate_negint globals destrs srcrs start_lbl dest_lbl def prf
    449   | Onotbool _ _ _ _ ⇒
    450       translate_notbool globals destrs srcrs start_lbl dest_lbl def
    451   | Onotint _ _ ⇒
    452     let f ≝ λdestr. λsrcr. sequential rtl_params_ globals (OP1 … Cmpl destr srcr) in
    453     let l ≝ map2 … f destrs srcrs prf in
    454       adds_graph rtl_params1 globals l start_lbl dest_lbl def
    455   | Optrofint _ _ r ⇒
    456       translate_move globals destrs srcrs start_lbl dest_lbl def
    457   | Ointofptr _ _ r ⇒
    458       translate_move globals destrs srcrs start_lbl dest_lbl def
    459   | Oid _ ⇒
    460       translate_move globals destrs srcrs start_lbl dest_lbl def
    461   | _ ⇒ ? (* float operations implemented in runtime *)
    462   ].
    463   cases not_implemented
    464 qed.
    465 
    466 let rec translate_mul1
    467   (globals: list ident) (dummy: register) (tmpr: register)
    468     (destrs: list register) (srcrs1: list register) (srcr2: register)
    469       (start_lbl: label)
    470         on srcrs1 ≝
    471   match destrs with
    472   [ nil ⇒ adds_graph rtl_params1 globals [ GOTO … ] start_lbl
    473   | cons destr tl ⇒
    474     match tl with
     512  λprf1: |destrs| = size_of_sig_type ty'.
     513  λprf2: |srcrs| = size_of_sig_type ty.
     514  match op1
     515  return λty'',ty'''.λx : unary_operation ty'' ty'''.ty'' = ty → ty''' = ty' →
     516    bind_new (localsT RTL) (list (joint_seq RTL globals)) with
     517  [ Ocastint _ src_sign _ _ ⇒ λeq1,eq2.
     518    translate_cast globals src_sign destrs srcrs
     519  | Onegint sz sg ⇒ λeq1,eq2.
     520    translate_negint globals destrs srcrs ?
     521  | Onotbool _ _ _ _ ⇒ λeq1,eq2.
     522    translate_notbool globals destrs srcrs
     523  | Onotint sz sg ⇒ λeq1,eq2.
     524    translate_notint globals destrs srcrs ?
     525  | Optrofint sz sg ⇒ λeq1,eq2.
     526    translate_cast globals Unsigned destrs srcrs
     527  | Ointofptr sz sg ⇒ λeq1,eq2.
     528    translate_cast globals Unsigned destrs srcrs
     529  | Oid t ⇒ λeq1,eq2.
     530      translate_move globals destrs (map … (Reg ?) srcrs) ?
     531  | _ ⇒ λeq1,eq2.? (* float operations implemented in runtime *)
     532  ] (refl …) (refl …).
     533  [3,4,5,6,7,8,9: (* floats *)  cases not_implemented
     534  |*: destruct >prf1 >prf2 [3: >length_map ] //
     535  ]
     536qed.
     537
     538include alias "arithmetics/nat.ma".
     539
     540let rec range_strong_internal (start : ℕ) (count : ℕ)
     541  (* Paolo: no notation to avoid ambiguity *)
     542  on count : list (Σn : ℕ.lt n (plus start count)) ≝
     543match count return λx.count = x → list (Σn : ℕ. n < start + count)
     544  with
     545[ O ⇒ λ_.[ ]
     546| S count' ⇒ λEQ.
     547  let f : (Σn : ℕ. lt n (S start + count')) → Σn : ℕ. lt n (start + count) ≝
     548    λsig.match sig with [mk_Sig n prf ⇒ n] in
     549  start :: map … f (range_strong_internal (S start) count')
     550] (refl …).
     551destruct(EQ) // qed.
     552
     553definition range_strong : ∀end : ℕ. list (Σn.n<end) ≝
     554  λend.range_strong_internal 0 end.
     555
     556definition translate_mul_i :
     557  ∀globals.
     558  register → register →
     559  (* size of destination and sources *)
     560  ∀n : ℕ.
     561  (* the temporary destination, with a dummy register at the end *)
     562  ∀tmp_destrs_dummy : list register.
     563  ∀srcrs1,srcrs2 : list psd_argument.
     564  |tmp_destrs_dummy| = S n →
     565  n = |srcrs1| →
     566  |srcrs1| = |srcrs2| →
     567  (* the position of the least significant byte of the result we compute at
     568     this stage (goes from 0 to n in the main function) *)
     569  ∀k : ℕ.
     570  lt k n →
     571  (* the position of the byte in the first source we will use in this stage.
     572     the position in the other source will be k - i *)
     573  (Σi.i<S k) →
     574  (* the accumulator *)
     575  list (joint_seq RTL globals) →
     576    list (joint_seq RTL globals) ≝
     577  λglobals,a,b,n,tmp_destrs_dummy,srcrs1,srcrs2,
     578    tmp_destrs_dummy_prf,srcrs1_prf,srcrs2_prf,k,k_prf,i_sig,acc.
     579  (* the following will expand to
     580     a, b ← srcrs1[i] * srcrs2[k-i]
     581     tmp_destrs_dummy[k]   ← tmp_destrs_dummy[k] + a
     582     tmp_destrs_dummy[k+1] ← tmp_destrs_dummy[k+1] + b + C
     583     tmp_destrs_dummy[k+2] ← tmp_destrs_dummy[k+2] + 0 + C
     584     ...
     585     tmp_destrs_dummy[n]   ← tmp_destrs_dummy[n] + 0 + C
     586     ( all calculations on tmp_destrs_dummy[n] will be eliminated with
     587     liveness analysis) *)
     588  match i_sig with
     589    [ mk_Sig i i_prf ⇒
     590      (* we pad the result of a byte multiplication with zeros in order
     591         for the bit to be carried. Redundant calculations will be eliminated
     592         by constant propagation. *)
     593      let args : list psd_argument ≝
     594        [Reg ? a;Reg ? b] @ make_list ? (zero_byte : psd_argument) (n - 1 - k) in
     595      let tmp_destrs_view : list register ≝
     596        ltl ? tmp_destrs_dummy k in
     597      ❮a, b❯ ← (nth_safe ? i srcrs1 ?) .Mul. (nth_safe ? (k - i) srcrs2 ?) ::
     598      translate_op … Add tmp_destrs_view (map … (Reg ?) tmp_destrs_view) args ?? @
     599      acc
     600    ].
     601[ @lt_plus_to_minus [ @le_S_S_to_le assumption | <srcrs2_prf <srcrs1_prf
     602  whd >(plus_n_O (S k)) @le_plus // ]
     603| <srcrs1_prf
     604  @(transitive_le … i_prf k_prf)
     605| >length_map //
     606| >length_map
     607  >length_ltl
     608  >tmp_destrs_dummy_prf >length_append
     609  >length_make_list
     610  normalize in ⊢ (???(?%?));
     611  >plus_minus_commutative
     612    [2: @le_plus_to_minus_r <plus_n_Sm <plus_n_O assumption]
     613  cut (S n = 2 + (n - 1))
     614    [2: #EQ >EQ %]
     615  >plus_minus_commutative
     616    [2: @(transitive_le … k_prf) //]
     617  @sym_eq
     618  @plus_to_minus %
     619] qed.
     620
     621definition translate_mul : ∀globals.?→?→?→?→?→bind_new (localsT RTL) (list (joint_seq RTL globals)) ≝
     622λglobals : list ident.
     623λdestrs : list register.
     624λsrcrs1 : list psd_argument.
     625λsrcrs2 : list psd_argument.
     626λsrcrs1_prf : |destrs| = |srcrs1|.
     627λsrcrs2_prf : |srcrs1| = |srcrs2|.
     628(* needed fresh registers *)
     629νa in
     630νb in
     631(* temporary registers for the result are created, so to avoid overwriting
     632   sources *)
     633νν |destrs| as tmp_destrs with tmp_destrs_prf in
     634νdummy in
     635(* the step calculating all products with least significant byte going in the
     636   k-th position of the result *)
     637let translate_mul_k : (Σk.k<|destrs|) → list (joint_seq RTL globals) →
     638  list (joint_seq RTL globals) ≝
     639  λk_sig,acc.match k_sig with
     640  [ mk_Sig k k_prf ⇒
     641    foldr … (translate_mul_i ? a b (|destrs|)
     642      (tmp_destrs @ [dummy]) srcrs1 srcrs2
     643      ? srcrs1_prf srcrs2_prf k k_prf) acc (range_strong (S k))
     644  ] in
     645(* initializing tmp_destrs to zero
     646   dummy is intentionally uninitialized *)
     647translate_fill_with_zero … tmp_destrs @
     648(* the main body, roughly:
     649   for k in 0 ... n-1 do
     650     for i in 0 ... k do
     651       translate_mul_i … k … i *)
     652foldr … translate_mul_k [ ] (range_strong (|destrs|)) @
     653(* epilogue: saving the result *)
     654translate_move … destrs (map … (Reg ?) tmp_destrs) ?.
     655[ >length_map >tmp_destrs_prf //
     656| >length_append <plus_n_Sm <plus_n_O //
     657]
     658qed.
     659
     660definition translate_divumodu8 : ∀globals.?→?→?→?→?→?→
     661    bind_new (localsT RTL) (list (joint_seq RTL globals)) ≝
     662  λglobals: list ident.
     663  λdiv_not_mod: bool.
     664  λdestrs: list register.
     665  λsrcrs1: list psd_argument.
     666  λsrcrs2: list psd_argument.
     667  λsrcrs1_prf : |destrs| = |srcrs1|.
     668  λsrcrs2_prf : |srcrs1| = |srcrs2|.
     669  match destrs return λx.x = destrs → bind_new ?? with
     670  [ nil ⇒ λ_.[ ]
     671  | cons destr destrs' ⇒ λeq_destrs.
     672    match destrs' with
    475673    [ nil ⇒
    476       match srcrs1 with
    477       [ nil ⇒
    478         adds_graph rtl_params1 globals [
    479           sequential … (INT rtl_params_ globals tmpr (zero …));
    480           sequential … (OP2 rtl_params_ globals Addc destr destr tmpr)
    481         ] start_lbl
    482       | cons srcr1 tl' ⇒
    483         adds_graph rtl_params1 globals [
    484           sequential … (OPACCS rtl_params_ globals Mul tmpr dummy srcr2 srcr1);
    485           sequential … (OP2 rtl_params_ globals Addc destr destr tmpr)
    486         ] start_lbl
    487       ]
    488     | cons destr2 destrs ⇒
    489       match srcrs1 with
    490       [ nil ⇒
    491         add_translates rtl_params1 globals [
    492           adds_graph rtl_params1 globals [
    493             sequential … (INT rtl_params_ globals tmpr (zero …));
    494             sequential … (OP2 rtl_params_ globals Addc destr destr tmpr);
    495             sequential … (OP2 rtl_params_ globals Addc destr2 tmpr tmpr)
    496           ];
    497           translate_cst globals (Ointconst I8 (zero …)) destrs
    498         ] start_lbl
    499       | cons srcr1 srcrs1 ⇒
    500         match destrs with
    501         [ nil ⇒
    502           add_translates rtl_params1 globals [
    503             adds_graph rtl_params1 globals [
    504               sequential … (INT rtl_params_ globals tmpr (zero …));
    505               sequential … (OP2 rtl_params_ globals Addc destr destr tmpr);
    506               sequential … (OP2 rtl_params_ globals Addc destr2 tmpr tmpr)
    507             ];
    508             translate_cst globals (Ointconst I8 (zero ?)) destrs
    509           ] start_lbl
    510         | cons destr2 destrs ⇒
    511           add_translates rtl_params1 globals [
    512             adds_graph rtl_params1 globals [
    513               sequential … (OPACCS rtl_params_ globals Mul tmpr destr2 srcr2 srcr1);
    514               sequential … (OP2 rtl_params_ globals Addc destr destr tmpr)
    515             ];
    516             translate_mul1 globals dummy tmpr (destr2 :: destrs) srcrs1 srcr2
    517           ] start_lbl
    518         ]
    519       ]
     674      match srcrs1 return λx.x = srcrs1 → bind_new ??  with
     675      [ nil ⇒ λeq_srcrs1.⊥
     676      | cons srcr1 srcrs1' ⇒ λeq_srcrs1.
     677        match srcrs2 return λx.x = srcrs2 → bind_new ??  with
     678        [ nil ⇒ λeq_srcrs2.⊥
     679        | cons srcr2 srcrs2' ⇒ λeq_srcrs2.
     680          νdummy in
     681          let 〈destr1, destr2〉 ≝
     682            if div_not_mod then 〈destr, dummy〉 else 〈dummy, destr〉 in
     683          [❮destr1, destr2❯ ← srcr1 .DivuModu. srcr2]
     684        ] (refl …)
     685      ] (refl …)
     686    | _ ⇒ ? (* not implemented *)
    520687    ]
    521   ].
    522 
    523 definition translate_muli ≝
    524   λglobals: list ident.
    525   λdummy: register.
    526   λtmpr: register.
    527   λdestrs: list register.
    528   λtmp_destrs: list register.
    529   λsrcrs1: list register.
    530   λdummy_lbl: label.
    531   λi: nat.
    532   λi_prf: i ≤ |tmp_destrs|.
    533   λtranslates: list ?.
    534   λsrcr2i: register.
    535   let 〈tmp_destrs1, tmp_destrs2〉 ≝ vsplit … tmp_destrs i i_prf in
    536   let tmp_destrs2' ≝
    537     match tmp_destrs2 with
    538     [ nil ⇒ [ ]
    539     | cons tmp_destr2 tmp_destrs2 ⇒ [
    540         adds_graph rtl_params1 globals [
    541           sequential rtl_params_ globals (CLEAR_CARRY …);
    542           sequential … (INT rtl_params_ globals tmp_destr2 (zero …))
    543         ];
    544         translate_mul1 globals dummy tmpr tmp_destrs2 srcrs1 srcr2i;
    545         translate_cst globals (Ointconst I8 (zero …)) tmp_destrs1;
    546         adds_graph rtl_params1 globals [
    547           sequential rtl_params_ globals (CLEAR_CARRY …)
    548         ];
    549         translate_op globals Addc destrs destrs tmp_destrs
    550       ]
    551     ]
    552   in
    553     translates @ tmp_destrs2'.
    554    
    555 let rec remove_n_first_internal
    556   (b: Type[0]) (n: nat) (the_list: list b) (i: nat)
    557     on the_list ≝
    558   match the_list with
    559   [ nil        ⇒ [ ]
    560   | cons hd tl ⇒
    561     match eqb i n with
    562     [ true  ⇒ the_list
    563     | false ⇒ remove_n_first_internal b n tl (S i)
    564     ]
    565   ].
    566    
    567 definition remove_n_first ≝
    568   λb: Type[0].
    569   λn: nat.
    570   λthe_list: list b.
    571     remove_n_first_internal b n the_list 0.
    572 
    573 axiom plus_m_n_eq_o_to_lt_m_o:
    574   ∀m, n, o: nat.
    575     m + n = o → m ≤ o.
    576 
    577 include alias "arithmetics/nat.ma".
    578 
    579 axiom minus_m_n_Sp_to_minus_m_Sn_p:
    580   ∀m, n, p: nat.
    581     minus m n = S p → minus m (S n) = p.
    582    
    583 let rec foldi_strong_internal
    584   (a: Type[0]) (b: Type[0]) (reference: nat) (the_list: list b)
    585     (f: ∀j: nat. ∀proof: lt j (|the_list|). a → b → a) (seed: a)
    586       (counter: nat) (counter_proof: minus reference counter = |the_list|)
    587         on the_list: a ≝
    588   match the_list return λx. the_list = x → (minus reference counter = |x|) → a with
    589   [ nil        ⇒ λidentity. λbase_case. seed
    590   | cons hd tl ⇒ λidentity. λstep_case.
    591     let f' ≝ λj: nat. λproof: j < |tl|. f j ? in
    592       foldi_strong_internal a b reference tl f' (f counter ? seed hd) (S counter) ?
    593   ] (refl … the_list) counter_proof.
    594   [1: cases daemon (* XXX: to do *)
    595   |2: generalize in match counter_proof;
    596       >identity
    597       #HYP
    598       normalize in HYP:(???%);
    599       generalize in match (minus_m_n_Sp_to_minus_m_Sn_p reference counter (|tl|) HYP);
    600       #ASSM assumption
    601   |3: >identity
    602       normalize
    603       normalize in proof;
    604       generalize in match(le_S … proof);
    605       #HYP assumption
    606   ]
    607 qed.
    608  
    609 definition foldi_strong ≝
    610   λa: Type[0].
    611   λb: Type[0].
    612   λthe_list: list b.
    613   λf: (∀i: nat. ∀proof: i < |the_list|. a → b → a).
    614   λseed: a.
    615     foldi_strong_internal a b (|the_list|) the_list f seed 0 ?.
    616   //
    617 qed.
    618  
    619 definition translate_mul ≝
     688  ] (refl …).
     689[3: elim not_implemented]
     690destruct normalize in srcrs1_prf; normalize in srcrs2_prf; destruct qed.
     691
     692(* Paolo: to be moved elsewhere *)
     693let rec foldr2 (A : Type[0]) (B : Type[0]) (C : Type[0]) (f : A→B→C→C) (init : C) (l1 : list A) (l2 : list B)
     694  (prf : |l1| = |l2|) on l1 : C ≝
     695  match l1 return λx.x = l1 → C with 
     696  [ nil ⇒ λ_.init
     697  | cons a l1' ⇒ λeq_l1.
     698    match l2 return λy.y = l2 → C with
     699    [ nil ⇒ λeq_l2.⊥
     700    | cons b l2' ⇒ λeq_l2.
     701      f a b (foldr2 A B C f init l1' l2' ?)
     702    ] (refl …)
     703  ] (refl …).
     704destruct normalize in prf;  [destruct|//]
     705qed.
     706
     707definition translate_ne: ∀globals: list ident.?→?→?→?→
     708  bind_new (localsT RTL) (list (joint_seq RTL globals)) ≝
    620709  λglobals: list ident.
    621710  λdestrs: list register.
    622   λsrcrs1: list register.
    623   λsrcrs2: list register.
    624   λregs_proof: |destrs| = |srcrs2|.
    625   λstart_lbl: label.
    626   λdest_lbl: label.
    627   λdef: rtl_internal_function globals.
    628   let 〈def, dummy〉 ≝ fresh_reg rtl_params0 globals def in
    629   let 〈def, tmpr〉 ≝ fresh_reg rtl_params0 globals def in
    630     match fresh_regs_strong rtl_params0 globals def (|destrs|) with
    631     [ mk_Sig def_tmp_destrs tmp_destrs_prf ⇒
    632       let def ≝ \fst def_tmp_destrs in
    633       let tmp_destrs ≝ \snd def_tmp_destrs in
    634       let 〈def, fresh_srcrs1〉 ≝ fresh_regs rtl_params0 globals def (|srcrs1|) in
    635       let 〈def, fresh_srcrs2〉 ≝ fresh_regs rtl_params0 globals def (|srcrs2|) in
    636       let insts_init ≝ [
    637         translate_move globals fresh_srcrs1 srcrs1;
    638         translate_move globals fresh_srcrs2 srcrs2;
    639         translate_cst globals (Ointconst I8 (zero …)) destrs
    640       ]
    641       in
    642         let f ≝ translate_muli globals dummy tmpr destrs tmp_destrs fresh_srcrs1 start_lbl in
    643         let f' ≝ λi. λi_proof: i < |srcrs2|. f i ? in
    644         let insts_mul ≝ foldi_strong … srcrs2 f' [ ] in
    645           add_translates rtl_params1 globals (insts_init @ insts_mul) start_lbl dest_lbl def
    646     ].
    647   >tmp_destrs_prf
    648   >regs_proof
    649   /2/
    650 qed.
    651 
    652 definition translate_divumodu8 ≝
    653   λglobals: list ident.
    654   λorder: bool.
    655   λdestrs: list register.
    656   λsrcr1: register.
    657   λsrcr2: register.
    658   λstart_lbl: label.
    659   λdest_lbl: label.
    660   λdef: rtl_internal_function globals.
    661   match destrs with
    662   [ nil ⇒ add_graph rtl_params1 globals start_lbl (GOTO … dest_lbl) def
    663   | cons destr destrs ⇒
    664     let 〈def, dummy〉 ≝ fresh_reg rtl_params0 globals def in
    665     let 〈destr1, destr2〉 ≝ match order with [ true ⇒ 〈destr, dummy〉 | _ ⇒ 〈dummy, destr〉 ] in
    666     let inst_div ≝ adds_graph rtl_params1 globals [
    667       sequential rtl_params_ globals (OPACCS … DivuModu destr1 destr2 srcr1 srcr2)
    668     ]
    669     in
    670     let insts_rest ≝ translate_cst globals (Ointconst I8 (zero ?)) destrs in
    671       add_translates rtl_params1 globals [ inst_div; insts_rest ] start_lbl dest_lbl def
    672   ].
    673 
    674 definition translate_ne: ∀globals: list ident. ? → ? → ? → ? → ? → ? → rtl_internal_function globals ≝
     711  λsrcrs1: list psd_argument.
     712  λsrcrs2: list psd_argument.
     713  match destrs return λ_.|srcrs1| = |srcrs2| → bind_new ?? with
     714  [ nil ⇒ λ_.[ ]
     715  | cons destr destrs' ⇒ λEQ.
     716    translate_fill_with_zero … destrs' @@
     717    match srcrs1 return λx.|x| = |srcrs2| → bind_new ?? with
     718    [ nil ⇒ λ_.[destr ← zero_byte]
     719    | cons srcr1 srcrs1' ⇒
     720      match srcrs2 return λx.S (|srcrs1'|) = |x| → bind_new ?? with
     721      [ nil ⇒ λEQ.⊥
     722      | cons srcr2 srcrs2' ⇒ λEQ.
     723        νtmpr in
     724        let f : psd_argument → psd_argument → list (joint_seq RTL globals) → list (joint_seq RTL globals) ≝
     725          λs1,s2,acc.
     726          tmpr  ← s1 .Xor. s2 ::
     727          destr ← destr .Or. tmpr ::
     728          acc in
     729        let epilogue : list (joint_seq RTL globals) ≝
     730          [ CLEAR_CARRY ?? ;
     731            tmpr ← zero_byte .Sub. destr ;
     732            (* now carry bit is 1 iff destrs != 0 *)
     733            destr ← zero_byte .Addc. zero_byte ] in
     734         destr ← srcr1 .Xor. srcr2 ::
     735         foldr2 ??? f epilogue srcrs1' srcrs2' ?
     736       ]
     737     ] EQ
     738   ]. normalize in EQ; destruct(EQ) assumption qed.
     739
     740(* if destrs is 0 or 1, it inverses it. To be used after operations that
     741   ensure this. *)
     742definition translate_toggle_bool : ∀globals.?→list (joint_seq RTL globals) ≝
    675743  λglobals: list ident.
    676744  λdestrs: list register.
    677   λsrcrs1: list register.
    678   λsrcrs2: list register.
    679   λstart_lbl: label.
    680   λdest_lbl: label.
    681   λdef: rtl_internal_function globals.
    682745  match destrs with
    683   [ nil ⇒ add_graph rtl_params1 globals start_lbl (GOTO … dest_lbl) def
    684   | cons destr destrs ⇒
    685     let 〈def, tmpr〉 ≝ fresh_reg rtl_params0 globals def in
    686     let 〈def, tmp_zero〉 ≝ fresh_reg rtl_params0 globals def in
    687     let 〈def, tmp_srcrs1〉 ≝ fresh_regs rtl_params0 globals def (|srcrs1|) in
    688     let save_srcrs1 ≝ translate_move globals tmp_srcrs1 srcrs1 in
    689     let 〈def, tmp_srcrs2〉 ≝ fresh_regs rtl_params0 globals def (|srcrs2|) in
    690     let save_srcrs2 ≝ translate_move globals tmp_srcrs2 srcrs2 in
    691     match reduce_strong register register tmp_srcrs1 tmp_srcrs2 with
    692     [ mk_Sig crl their_proof ⇒
    693       let commonl ≝ \fst (\fst crl) in
    694       let commonr ≝ \fst (\snd crl) in
    695       let restl ≝ \snd (\snd crl) in
    696       let restr ≝ \snd (\snd crl) in
    697       let rest ≝ restl @ restr in
    698       let inits ≝ [
    699         sequential … (INT rtl_params_ globals destr (zero …));
    700         sequential … (INT rtl_params_ globals tmp_zero (zero …))
    701       ]
    702       in
    703       let f_common ≝ λtmp_srcr1. λtmp_srcr2. [
    704         sequential … (CLEAR_CARRY …);
    705         sequential … (OP2 rtl_params_ globals Sub tmpr tmp_srcr1 tmp_srcr2);
    706         sequential … (OP2 rtl_params_ globals Or destr destr tmpr)
    707       ]
    708       in
    709       let insts_common ≝ flatten … (map2 … f_common commonl commonr ?) in
    710       let f_rest ≝ λtmp_srcr. [
    711         sequential … (CLEAR_CARRY …);
    712         sequential … (OP2 rtl_params_ globals Sub tmpr tmp_zero tmp_srcr);
    713         sequential … (OP2 rtl_params_ globals Or destr destr tmpr)
    714       ]
    715       in
    716       let insts_rest ≝ flatten … (map … f_rest rest) in
    717       let insts ≝ inits @ insts_common @ insts_rest in
    718       let epilogue ≝ translate_cst globals (Ointconst I8 (zero …)) destrs in
    719         add_translates rtl_params1 globals [
    720           save_srcrs1; save_srcrs2; adds_graph rtl_params1 globals insts; epilogue
    721         ] start_lbl dest_lbl def
     746  [ nil ⇒ [ ]
     747  | cons destr _ ⇒ [destr ← .Cmpl. destr]
     748  ].
     749 
     750definition translate_lt_unsigned :
     751  ∀globals.
     752  ∀destrs: list register.
     753  ∀srcrs1: list psd_argument.
     754  ∀srcrs2: list psd_argument.
     755  |srcrs1| = |srcrs2| →
     756  bind_new (localsT RTL) (list (joint_seq RTL globals)) ≝
     757  λglobals,destrs,srcrs1,srcrs2,srcrs_prf.
     758  match destrs with
     759  [ nil ⇒ [ ]
     760  | cons destr destrs' ⇒
     761    ν tmpr in
     762    (translate_fill_with_zero … destrs' @
     763    (* I perform a subtraction, but the only interest is in the carry bit *)
     764    translate_op ? Sub (make_list … tmpr (|srcrs1|)) srcrs1 srcrs2 ? srcrs_prf @
     765    [ destr ← zero_byte .Addc. zero_byte ])
     766  ].
     767>length_make_list % qed.
     768
     769(* shifts signed integers by adding 128 to the most significant byte
     770   it replaces it with a fresh register which must be provided *)
     771let rec shift_signed globals
     772  (tmp : register)
     773  (srcrs : list psd_argument) on srcrs :
     774  Σt : (list psd_argument) × (list (joint_seq RTL globals)).|\fst t| = |srcrs| ≝
     775  let byte_128 : Byte ≝ true ::: bv_zero ? in
     776  match srcrs with
     777  [ nil ⇒ 〈[ ],[ ]〉
     778  | cons srcr srcrs' ⇒
     779    match srcrs' with
     780    [ nil ⇒ 〈[ Reg ? tmp ], [ tmp ← srcr .Add. byte_128 ]〉
     781    | _ ⇒
     782      let re ≝ shift_signed globals tmp srcrs' in
     783      〈srcr :: \fst re, \snd re〉
    722784    ]
    723785  ].
    724   @their_proof
    725 qed.
    726 
    727 definition translate_eq_reg ≝
    728   λglobals: list ident.
    729   λtmp_zero: register.
    730   λtmp_one: register.
    731   λtmpr1: register.
    732   λtmpr2: register.
    733   λdestr: register.
    734   λdummy_lbl: label.
    735   λsrcr12: register × register.
    736   let 〈srcr1, srcr2〉 ≝ srcr12 in
    737   [ sequential … (CLEAR_CARRY …);
    738     sequential rtl_params_ globals (OP2 rtl_params_ globals Sub tmpr1 srcr1 srcr2);
    739     sequential … (OP2 rtl_params_ globals Addc tmpr1 tmp_zero tmp_zero);
    740     sequential … (OP2 rtl_params_ globals Sub tmpr2 srcr2 srcr1);
    741     sequential … (OP2 rtl_params_ globals Addc tmpr2 tmp_zero tmp_zero);
    742     sequential … (OP2 rtl_params_ globals Or tmpr1 tmpr1 tmpr2);
    743     sequential … (OP2 rtl_params_ globals Xor tmpr1 tmpr1 tmp_one);
    744     sequential … (OP2 rtl_params_ globals And destr destr tmpr1) ].
    745 
    746 definition translate_eq_list ≝
    747   λglobals: list ident.
    748   λtmp_zero: register.
    749   λtmp_one: register.
    750   λtmpr1: register.
    751   λtmpr2: register.
    752   λdestr: register.
    753   λleq: list (register × register).
    754   λdummy_lbl: label.
    755   let f ≝ translate_eq_reg globals tmp_zero tmp_one tmpr1 tmpr2 destr dummy_lbl in
    756     (sequential … (INT rtl_params_ globals destr (bitvector_of_nat ? 1))) ::
    757       flatten … (map … f leq).
    758 
    759 definition translate_atom ≝
    760   λglobals: list ident.
    761   λtmp_zero: register.
    762   λtmp_one: register.
    763   λtmpr1: register.
    764   λtmpr2: register.
    765   λtmpr3: register.
    766   λdestr: register.
    767   λdummy_lbl: label.
    768   λleq: list (register × register).
    769   λsrcr1: register.
    770   λsrcr2: register.
    771     translate_eq_list globals tmp_zero tmp_one tmpr1 tmpr2 tmpr3 leq dummy_lbl @
    772     [ sequential … (CLEAR_CARRY …);
    773       sequential … (OP2 rtl_params_ globals Sub tmpr1 srcr1 srcr2);
    774       sequential … (OP2 rtl_params_ globals Addc tmpr1 tmp_zero tmp_zero);
    775       sequential … (OP2 rtl_params_ globals And tmpr3 tmpr3 tmpr1);
    776       sequential … (OP2 rtl_params_ globals Or destr destr tmpr3) ].
    777 
    778 definition translate_lt_main ≝
    779   λglobals: list ident.
    780   λtmp_zero: register.
    781   λtmp_one: register.
    782   λtmpr1: register.
    783   λtmpr2: register.
    784   λtmpr3: register.
    785   λdestr: register.
    786   λdummy_lbl: label.
    787   λsrcrs1: list register.
    788   λsrcrs2: list register.
    789   λproof: |srcrs1| = |srcrs2|.
    790   let f ≝ λinsts_leq. λsrcr1. λsrcr2.
    791     let 〈insts, leq〉 ≝ insts_leq in
    792     let added_insts ≝ translate_atom globals tmp_zero tmp_one tmpr1 tmpr2 tmpr3 destr dummy_lbl leq srcr1 srcr2 in
    793       〈insts @ added_insts, leq @ [〈srcr1, srcr2〉]〉
    794   in
    795     \fst (fold_left2 … f 〈[ ], [ ]〉 srcrs1 srcrs2 proof).
    796 
    797 definition fresh_regs_strong:
    798   ∀globals. rtl_internal_function globals → ∀n: nat. Σfresh: (rtl_internal_function globals) × (list register). |\snd fresh| = n ≝
    799   λglobals: list ident.
    800   λdef.
    801   λn.
    802     fresh_regs rtl_params0 globals def n.
    803   @fresh_regs_length
    804 qed.
    805 
    806 definition complete_regs_strong:
    807   ∀globals: list ident. rtl_internal_function globals → list register → list register → Σcomplete: (list register) × (list register) × (list register). |\fst (\fst complete)| = |\snd (\fst complete)| ≝
    808   λglobals: list ident.
    809   λdef.
    810   λleft.
    811   λright.
    812     complete_regs globals def left right.
    813   @complete_regs_length
    814 qed.
    815 
    816 definition translate_lt ≝
    817   λglobals: list ident.
    818   λdestrs: list register.
    819   λprf_destrs: 0 < |destrs|.
    820   λsrcrs1: list register.
    821   λsrcrs2: list register.
    822   λstart_lbl: label.
    823   λdest_lbl: label.
    824   λdef: rtl_internal_function globals.
    825   match destrs with
    826   [ nil ⇒ add_graph rtl_params1 globals start_lbl (GOTO … dest_lbl) def
    827   | _ ⇒
    828     match fresh_regs_strong globals def (|destrs|) with
    829     [ mk_Sig def_tmp_destrs tmp_destrs_proof ⇒
    830       let def ≝ \fst def_tmp_destrs in
    831       let tmp_destrs ≝ \snd def_tmp_destrs in
    832       let tmp_destr ≝ hd_safe ? tmp_destrs ? in
    833       let 〈def, tmp_zero〉 ≝ fresh_reg rtl_params1 globals def in
    834       let 〈def, tmp_one〉 ≝ fresh_reg rtl_params1 globals def in
    835       let 〈def, tmpr1〉 ≝ fresh_reg rtl_params1 globals def in
    836       let 〈def, tmpr2〉 ≝ fresh_reg rtl_params1 globals def in
    837       let 〈def, tmpr3〉 ≝ fresh_reg rtl_params1 globals def in
    838       match complete_regs_strong globals def srcrs1 srcrs2 with
    839       [ mk_Sig srcrs12_added srcrs12_proof ⇒
    840         let srcrs1 ≝ \fst (\fst srcrs12_added) in
    841         let srcrs2 ≝ \snd (\fst srcrs12_added) in
    842         let added ≝ \snd srcrs12_added in
    843         let srcrs1' ≝ rev … srcrs1 in
    844         let srcrs2' ≝ rev … srcrs2 in
    845         let insts_init ≝ [
    846           translate_cst globals (Ointconst I8 (zero ?)) tmp_destrs;
    847           translate_cst globals (Ointconst I8 (zero ?)) added;
    848           adds_graph rtl_params1 globals [
    849             sequential rtl_params_ globals (INT rtl_params_ globals tmp_zero (zero …));
    850             sequential rtl_params_ globals (INT rtl_params_ globals tmp_one (bitvector_of_nat … 1))
    851           ]
    852         ]
    853         in
    854         let insts_main ≝
    855           translate_lt_main globals tmp_zero tmp_one tmpr1 tmpr2 tmpr3 tmp_destr start_lbl srcrs1' srcrs2' ? in
    856           let insts_main ≝ [ adds_graph rtl_params1 globals insts_main ] in
    857           let insts_exit ≝ [ translate_move globals destrs tmp_destrs ] in
    858             add_translates rtl_params1 globals (insts_init @ insts_main @ insts_exit) start_lbl dest_lbl def
    859       ]
    860     ]
    861   ].
    862   [2: >tmp_destrs_proof @prf_destrs
    863   |1: normalize nodelta
    864       generalize in match srcrs12_proof;
    865       #HYP >rev_length >rev_length @HYP
    866   ]
    867 qed.
    868 
    869 definition add_128_to_last ≝
    870   λglobals: list ident.
    871   λtmp_128: register.
    872   λrs.
    873   λprf: 0 < |rs|.
    874   λstart_lbl: label.
    875   match rs with
    876   [ nil ⇒ adds_graph rtl_params1 globals [ ] start_lbl
    877   | _ ⇒
    878     let r ≝ last_safe … rs prf in
    879       adds_graph rtl_params1 globals [
    880         sequential rtl_params_ globals (OP2 rtl_params_ globals Add r r tmp_128)
    881       ] start_lbl
    882   ].
    883 
    884 definition translate_lts ≝
    885   λglobals: list ident.
    886   λdestrs: list register.
    887   λdestrs_prf: 0 < |destrs|.
    888   λsrcrs1: list register.
    889   λsrcrs2: list register.
    890   λsrcrs1_lt_prf: 0 < |srcrs1|.
    891   λsrcrs2_lt_prf: 0 < |srcrs2|.
    892   λstart_lbl: label.
    893   λdest_lbl: label.
    894   λdef: rtl_internal_function globals.
    895   match fresh_regs_strong globals def (|srcrs1|) with
    896   [ mk_Sig def_tmp_srcrs1 srcrs1_prf ⇒
    897     let def ≝ \fst def_tmp_srcrs1 in
    898     let tmp_srcrs1 ≝ \snd def_tmp_srcrs1 in
    899     match fresh_regs_strong globals def (|srcrs2|) with
    900     [ mk_Sig def_tmp_srcrs2 srcrs2_prf ⇒
    901       let def ≝ \fst def_tmp_srcrs2 in
    902       let tmp_srcrs2 ≝ \snd def_tmp_srcrs2 in
    903       let 〈def, tmp_128〉 ≝ fresh_reg rtl_params0 globals def in
    904         add_translates rtl_params1 globals [
    905           translate_move globals tmp_srcrs1 srcrs1;
    906           translate_move globals tmp_srcrs2 srcrs2;
    907           adds_graph rtl_params1 globals [
    908             sequential rtl_params_ globals (INT rtl_params_ globals tmp_128 (bitvector_of_nat ? 128))
    909           ];
    910           add_128_to_last globals tmp_128 tmp_srcrs1 ?;
    911           add_128_to_last globals tmp_128 tmp_srcrs2 ?;
    912           translate_lt globals destrs destrs_prf tmp_srcrs1 tmp_srcrs2
    913         ] start_lbl dest_lbl def
    914     ]
    915   ].
    916   [1: >srcrs1_prf @srcrs1_lt_prf
    917   |2: >srcrs2_prf @srcrs2_lt_prf
    918   ]
    919 qed.
    920 
    921 definition translate_op2 ≝
    922   λglobals: list ident.
    923   λop2.
    924   λdestrs: list register.
    925   λdestrs_prf: 0 < |destrs|.
    926   λsrcrs1: list register.
    927   λsrcrs2: list register.
    928   λsrcrs2_destrs_prf: |srcrs2| = |destrs|.
    929   λsrcrs1_destrs_prf: |srcrs1| = |destrs|.
    930   λstart_lbl: label.
    931   λdest_lbl: label.
    932   λdef: rtl_internal_function globals.
    933   match op2 with
    934   [ Oadd ⇒
    935     translate_op globals Addc destrs srcrs1 srcrs2 start_lbl dest_lbl def
    936   | Oaddp ⇒
    937     translate_op globals Addc destrs srcrs1 srcrs2 start_lbl dest_lbl def
    938   | Osub ⇒
    939     translate_op globals Sub destrs srcrs1 srcrs2 start_lbl dest_lbl def
    940   | Osubpi ⇒
    941     translate_op globals Sub destrs srcrs1 srcrs2 start_lbl dest_lbl def
    942   | Osubpp sz ⇒
    943     translate_op globals Sub destrs srcrs1 srcrs2 start_lbl dest_lbl def
    944   | Omul ⇒
    945     translate_mul globals destrs srcrs1 srcrs2 ? start_lbl dest_lbl def
    946   | Odivu ⇒
    947     match srcrs1 return λx. 0 < |x| → rtl_internal_function globals with
    948     [ cons hd tl ⇒ λcons_prf.
    949       match tl with
    950       [ nil ⇒ translate_divumodu8 globals true destrs hd (hd_safe register srcrs2 ?) start_lbl dest_lbl def
    951       | _ ⇒ ? (* not implemented *)
    952       ]
    953     | nil ⇒ λnil_absrd. ?
    954     ] ?
    955   | Omodu ⇒
    956     match srcrs1 return λx. 0 < |x| → rtl_internal_function globals with
    957     [ cons hd tl ⇒ λcons_prf.
    958       match tl with
    959       [ nil ⇒ translate_divumodu8 globals false destrs hd (hd_safe register srcrs2 ?) start_lbl dest_lbl def
    960       | _ ⇒ ? (* not implemented *)
    961       ]
    962     | nil ⇒ λnil_absrd. ?
    963     ] ?
    964   | Oand ⇒
    965     translate_op globals And destrs srcrs1 srcrs2 start_lbl dest_lbl def
    966   | Oor ⇒
    967     translate_op globals Or destrs srcrs1 srcrs2 start_lbl dest_lbl def
    968   | Oxor ⇒
    969     translate_op globals Xor destrs srcrs1 srcrs2 start_lbl dest_lbl def
    970   | Ocmp c ⇒
    971     match c with
    972     [ Ceq ⇒
    973       add_translates rtl_params1 globals [
    974         translate_ne globals destrs srcrs1 srcrs2;
    975         translate_op1 globals ?? (Onotbool (ASTint I8 Unsigned) I8 Unsigned I) destrs destrs (refl ? (|destrs|))
    976       ] start_lbl dest_lbl def
    977     | Cne ⇒ translate_ne globals destrs srcrs1 srcrs2 start_lbl dest_lbl def
    978     | Clt ⇒ translate_lts globals destrs destrs_prf srcrs1 srcrs2 ? ? start_lbl dest_lbl def
    979     | Cgt ⇒ translate_lts globals destrs destrs_prf srcrs2 srcrs1 ? ? start_lbl dest_lbl def
    980     | Cle ⇒
    981       add_translates rtl_params1 globals [
    982         translate_lts globals destrs destrs_prf srcrs2 srcrs1 ? ?;
    983         translate_op1 globals ?? (Onotbool (ASTint I8 Unsigned) I8 Unsigned I) destrs destrs (refl ? (|destrs|))
    984       ] start_lbl dest_lbl def
    985     | Cge ⇒
    986       add_translates rtl_params1 globals [
    987         translate_lts globals destrs destrs_prf srcrs1 srcrs2 ? ?;
    988         translate_op1 globals ?? (Onotbool (ASTint I8 Unsigned) I8 Unsigned I) destrs destrs (refl ? (|destrs|))
    989       ] start_lbl dest_lbl def
    990     ]
    991   | Ocmpu c ⇒
    992     match c with
    993     [ Ceq ⇒
    994       add_translates rtl_params1 globals [
    995         translate_ne globals destrs srcrs1 srcrs2;
    996         translate_op1 globals ?? (Onotbool (ASTint I8 Unsigned) I8 Unsigned I) destrs destrs (refl ? (|destrs|))
    997       ] start_lbl dest_lbl def
    998     | Cne ⇒ translate_ne globals destrs srcrs1 srcrs2 start_lbl dest_lbl def
    999     | Clt ⇒ translate_lt globals destrs destrs_prf srcrs1 srcrs2 start_lbl dest_lbl def
    1000     | Cgt ⇒ translate_lt globals destrs destrs_prf srcrs2 srcrs1 start_lbl dest_lbl def
    1001     | Cle ⇒
    1002       add_translates rtl_params1 globals [
    1003         translate_lt globals destrs destrs_prf srcrs2 srcrs1;
    1004         translate_op1 globals ?? (Onotbool (ASTint I8 Unsigned) I8 Unsigned I) destrs destrs (refl ? (|destrs|))
    1005       ] start_lbl dest_lbl def
    1006     | Cge ⇒
    1007       add_translates rtl_params1 globals [
    1008         translate_lt globals destrs destrs_prf srcrs1 srcrs2;
    1009         translate_op1 globals ?? (Onotbool (ASTint I8 Unsigned) I8 Unsigned I) destrs destrs (refl ? (|destrs|))
    1010       ] start_lbl dest_lbl def
    1011     ]
    1012   | Ocmpp c ⇒
    1013     match c with
    1014     [ Ceq ⇒
    1015       add_translates rtl_params1 globals [
    1016         translate_ne globals destrs srcrs1 srcrs2;
    1017         translate_op1 globals ?? (Onotbool (ASTint I8 Unsigned) I8 Unsigned I) destrs destrs (refl ? (|destrs|))
    1018       ] start_lbl dest_lbl def
    1019     | Cne ⇒ translate_ne globals destrs srcrs1 srcrs2 start_lbl dest_lbl def
    1020     | Clt ⇒ translate_lt globals destrs destrs_prf srcrs1 srcrs2 start_lbl dest_lbl def
    1021     | Cgt ⇒ translate_lt globals destrs destrs_prf srcrs2 srcrs1 start_lbl dest_lbl def
    1022     | Cle ⇒
    1023       add_translates rtl_params1 globals [
    1024         translate_lt globals destrs destrs_prf srcrs2 srcrs1;
    1025         translate_op1 globals ?? (Onotbool (ASTint I8 Unsigned) I8 Unsigned I) destrs destrs (refl ? (|destrs|))
    1026       ] start_lbl dest_lbl def
    1027     | Cge ⇒
    1028       add_translates rtl_params1 globals [
    1029         translate_lt globals destrs destrs_prf srcrs1 srcrs2;
    1030         translate_op1 globals ?? (Onotbool (ASTint I8 Unsigned) I8 Unsigned I) destrs destrs (refl ? (|destrs|))
    1031       ] start_lbl dest_lbl def
    1032     ]
    1033   | _ ⇒ ? (* assert false, implemented in run time or float op *)
    1034   ].
    1035   [1:
    1036     @sym_eq
    1037     assumption
    1038   |3,8,19,22,24,25:
    1039     >srcrs1_destrs_prf
    1040     assumption
    1041   |4,9:
    1042     normalize in nil_absrd;
    1043     cases(not_le_Sn_O 0)
    1044     #HYP cases(HYP nil_absrd)
    1045   |5,10,20,21,23,26:
    1046     >srcrs2_destrs_prf
    1047     assumption
    1048   |*:
    1049     cases not_implemented (* XXX: yes, really *)
    1050   ]
    1051 qed.
    1052 
    1053 definition translate_cond: ∀globals: list ident. list register → label → label → label → rtl_internal_function globals → rtl_internal_function globals ≝
     786[1,2: %
     787|*: cases re * #a #b >p1 normalize #EQ >EQ %
     788] qed.
     789
     790definition translate_lt_signed :
     791  ∀globals.
     792  ∀destrs: list register.
     793  ∀srcrs1: list psd_argument.
     794  ∀srcrs2: list psd_argument.
     795  |srcrs1| = |srcrs2| →
     796  bind_new (localsT RTL) (list (joint_seq RTL globals)) ≝
     797  λglobals,destrs,srcrs1,srcrs2,srcrs_prf.
     798  νtmp_last_s1 in
     799  νtmp_last_s2 in
     800  let p1 ≝ shift_signed globals tmp_last_s1 srcrs1 in
     801  let new_srcrs1 ≝ \fst p1 in
     802  let shift_srcrs1 ≝ \snd p1 in
     803  let p2 ≝ shift_signed globals tmp_last_s2 srcrs2 in
     804  let new_srcrs2 ≝ \fst p2 in
     805  let shift_srcrs2 ≝ \snd p2 in