source: src/Clight/switchRemoval.ma @ 2304

Last change on this file since 2304 was 2304, checked in by garnier, 7 years ago

Strengthened proof of associativity of bitvector addition. Some more lemmas on two complement negation wrt addition proved, through a slight detour using an ad-hoc definition of addition with explicit carries.
All of that to prove that -(a + b) = -a + -b, needed in turn for a simulation result on pointer subtractions.
switchRemoval.ma now typechecks. TBF: simulation proof for the transformation itself.

  • Property svn:executable set to *
File size: 220.1 KB
Line 
1include "Clight/Csyntax.ma".
2include "Clight/fresh.ma".
3include "basics/lists/list.ma".
4include "common/Identifiers.ma".
5include "Clight/Cexec.ma".
6include "Clight/CexecInd.ma".
7include "Clight/frontend_misc.ma".
8include "Clight/casts.ma". (* lemmas related to bitvectors ... *)
9
10(*
11include "Clight/maps_obsequiv.ma".
12*)
13
14
15(* -----------------------------------------------------------------------------
16   ----------------------------------------------------------------------------*)
17
18(* -----------------------------------------------------------------------------
19   Documentation
20   ----------------------------------------------------------------------------*)
21
22(* This file implements transformation of switches to linear sequences of
23 * if/then/else. The implementation roughly follows the lines of the prototype.
24 * /!\ We assume that the program is well-typed (the type of the evaluated
25 * expression must match the constants on each branch of the switch). /!\ *)
26
27(* Documentation. Let the follwing be our input switch construct:
28   // --------------------------------- 
29   switch(e) {
30   case v1:
31     stmt1
32   case v2:
33     stmt2
34   .
35   .
36   .
37   default:
38     stmt_default
39   }
40   // --------------------------------- 
41 
42   Note that stmt1,stmt2, ... stmt_default may contain "break" statements, wich have the effect of exiting
43   the switch statement. In the absence of break, the execution falls through each case sequentially.
44 
45   Given such a statement, we produce an equivalent sequence of if-then-elses chained by gotos:
46
47   // --------------------------------- 
48   fresh = e;
49   if(fresh == v1) {
50     stmt1';
51     goto lbl_case2;
52   }
53   if(fresh == v2) {
54     lbl_case2:
55     stmt2';
56     goto lbl_case2;
57   }   
58   ...
59   stmt_default';
60   exit_label:
61   // ---------------------------------   
62
63   where stmt1', stmt2', ... stmt_default' are the statements where all top-level [break] statements
64   were replaced by [goto exit_label]. Note that fresh, lbl_casei are fresh identifiers and labels.
65*)
66
67
68(* -----------------------------------------------------------------------------
69   Definitions allowing to state that the program resulting of the transformation
70   is switch-free.
71   ---------------------------------------------------------------------------- *)
72
73(* Property of a Clight statement of containing no switch. Could be generalized into a kind of
74 * statement_P, if useful elsewhere. *)
75let rec switch_free (st : statement) : Prop ≝
76match st with
77[ Sskip ⇒ True
78| Sassign _ _ ⇒ True
79| Scall _ _ _ ⇒ True
80| Ssequence s1 s2 ⇒ switch_free s1 ∧ switch_free s2
81| Sifthenelse e s1 s2 ⇒ switch_free s1 ∧ switch_free s2
82| Swhile e body ⇒ switch_free body
83| Sdowhile e body ⇒ switch_free body
84| Sfor s1 _ s2 s3 ⇒ switch_free s1 ∧ switch_free s2 ∧ switch_free s3
85| Sbreak ⇒ True
86| Scontinue ⇒ True
87| Sreturn _ ⇒ True
88| Sswitch _ _ ⇒ False
89| Slabel _ body ⇒ switch_free body
90| Sgoto _ ⇒ True
91| Scost _ body ⇒ switch_free body
92].
93
94(* Property of a list of labeled statements of being switch-free *)
95let rec branches_switch_free (sts : labeled_statements) : Prop ≝
96match sts with
97[ LSdefault st =>
98  switch_free st
99| LScase _ _ st tl =>
100  switch_free st ∧ branches_switch_free tl
101].
102
103let rec branches_ind
104  (sts : labeled_statements)
105  (H   : labeled_statements → Prop) 
106  (defcase : ∀st. H (LSdefault st))
107  (indcase : ∀sz.∀int.∀st.∀sub_cases. H sub_cases → H (LScase sz int st sub_cases)) ≝
108match sts with
109[ LSdefault st ⇒
110  defcase st
111| LScase sz int st tl ⇒
112  indcase sz int st tl (branches_ind tl H defcase indcase)
113].
114
115(* -----------------------------------------------------------------------------
116   Switch-removal code for statements, functions and fundefs.
117   ----------------------------------------------------------------------------*)
118
119(* Converts the directly accessible ("free") breaks to gotos toward the [lab] label.  *)
120let rec convert_break_to_goto (st : statement) (lab : label) : statement ≝
121match st with
122[ Sbreak ⇒
123  Sgoto lab
124| Ssequence s1 s2 ⇒
125  Ssequence (convert_break_to_goto s1 lab) (convert_break_to_goto s2 lab)
126| Sifthenelse e iftrue iffalse ⇒
127  Sifthenelse e (convert_break_to_goto iftrue lab) (convert_break_to_goto iffalse lab)
128| Sfor init e update body ⇒
129  Sfor (convert_break_to_goto init lab) e update body
130| Slabel l body ⇒
131  Slabel l (convert_break_to_goto body lab)
132| Scost cost body ⇒
133  Scost cost (convert_break_to_goto body lab)
134| _ ⇒ st
135].
136
137(* Converting breaks preserves switch-freeness. *)
138lemma convert_break_lift : ∀s,label . switch_free s → switch_free (convert_break_to_goto s label).
139#s elim s //
140[ 1: #s1 #s2 #Hind1 #Hind2 #label * #Hsf1 #Hsf2 /3/
141| 2: #e #s1 #s2 #Hind1 #Hind2 #label * #Hsf1 #Hsf2 /3/
142| 3: #s1 #e #s2 #s3 #Hind1 #Hind2 #Hind3 #label * * #Hsf1 #Hsf2 #Hsf3 normalize
143     try @conj try @conj /3/
144| 4: #l #s0 #Hind #lab #Hsf whd in Hsf; normalize /2/
145| 5: #l #s0 #Hind #lab #Hsf whd in Hsf; normalize /3/
146] qed.
147
148(* Obsolete. This version generates a nested pseudo-sequence of if-then-elses. *)
149(*
150let rec produce_cond
151  (e : expr)
152  (switch_cases : stlist)
153  (def_case : ident × sf_statement)
154  (exit : label) on switch_cases : sf_statement × label ≝
155match switch_cases with
156[ nil ⇒
157  match def_case with
158  [ mk_Prod default_label default_statement ⇒
159    〈«Slabel default_label (convert_break_to_goto (pi1 … default_statement) exit), ?», default_label〉
160  ]
161| cons switch_case tail ⇒
162  let 〈case_label, case_value, case_statement〉 ≝ switch_case in
163    match case_value with
164    [ mk_DPair sz val ⇒
165       let test ≝ Expr (Ebinop Oeq e (Expr (Econst_int sz val) (typeof e))) (Tint I32 Signed) in
166       (* let test ≝ Expr (Ebinop Oeq e e) (Tint I32 Unsigned) in *)
167       (* let test ≝ Expr (Econst_int I32 (bvzero 32)) (Tint I32 Signed)  in *)
168       let 〈sub_statement, sub_label〉 ≝ produce_cond e tail def_case exit in
169       let result ≝
170         Sifthenelse test
171          (Slabel case_label
172            (Ssequence (convert_break_to_goto (pi1 … case_statement) exit)
173                       (Sgoto sub_label)))
174          (pi1 … sub_statement)
175      in
176      〈«result, ?», case_label〉
177    ]
178].
179[ 1: normalize @convert_break_lift elim default_statement //
180| 2: whd @conj normalize try @conj try //
181  [ 1: @convert_break_lift elim case_statement //
182  | 2: elim sub_statement // ]
183] qed. *)
184
185(* We assume that the expression e is consistely typed w.r.t. the switch branches *)
186(*
187let rec produce_cond2
188  (e : expr)
189  (switch_cases : stlist)
190  (def_case : ident × sf_statement)
191  (exit : label) on switch_cases : sf_statement × label ≝
192match switch_cases with
193[ nil ⇒
194  let 〈default_label, default_statement〉 ≝ def_case in
195  〈«Slabel default_label (convert_break_to_goto (pi1 … default_statement) exit), ?», default_label〉
196| cons switch_case tail ⇒
197  let 〈case_label, case_value, case_statement〉 ≝ switch_case in
198  match case_value with
199  [ mk_DPair sz val ⇒
200    let test ≝ Expr (Ebinop Oeq e (Expr (Econst_int sz val) (typeof e))) (Tint I32 Signed) in
201    let 〈sub_statement, sub_label〉 ≝ produce_cond2 e tail def_case exit in
202    let case_statement_res ≝
203       Sifthenelse test
204        (Slabel case_label
205          (Ssequence (convert_break_to_goto (pi1 … case_statement) exit)
206                     (Sgoto sub_label)))
207        Sskip
208    in
209    〈«Ssequence case_statement_res (pi1 … sub_statement), ?», case_label〉
210  ]
211].
212[ 1: normalize @convert_break_lift elim default_statement //
213| 2: whd @conj
214     [ 1: whd @conj try // whd in match (switch_free ?); @conj
215          [ 1: @convert_break_lift elim case_statement //
216          | 2: // ]
217     | 2: elim sub_statement // ]
218] qed. *)
219
220(*  (def_case : ident × sf_statement) *)
221
222let rec produce_cond
223  (e : expr)
224  (switch_cases : labeled_statements)
225  (u : universe SymbolTag)
226  (exit : label) on switch_cases : statement × label × (universe SymbolTag) ≝
227match switch_cases with
228[ LSdefault st ⇒ 
229  let 〈lab,u1〉 ≝ fresh ? u in
230  let st' ≝ convert_break_to_goto st exit in
231  〈Slabel lab st', lab, u1〉
232| LScase sz tag st other_cases ⇒
233  let 〈sub_statements, sub_label, u1〉 ≝ produce_cond e other_cases u exit in
234  let st' ≝ convert_break_to_goto st exit in
235  let 〈lab, u2〉 ≝ fresh ? u1 in
236  let test ≝ Expr (Ebinop Oeq e (Expr (Econst_int sz tag) (typeof e))) (Tint I32 Signed) in
237  let case_statement ≝
238       Sifthenelse test
239        (Slabel lab (Ssequence st' (Sgoto sub_label)))
240        Sskip
241  in
242  〈Ssequence case_statement sub_statements, lab, u2〉
243].
244
245definition simplify_switch ≝
246   λ(e : expr).
247   λ(switch_cases : labeled_statements).
248   λ(uv : universe SymbolTag).
249 let 〈exit_label, uv1〉            ≝ fresh ? uv in
250 let 〈result, useless_label, uv2〉 ≝ produce_cond e switch_cases uv1 exit_label in
251 〈Ssequence result (Slabel exit_label Sskip), uv2〉.
252
253lemma produce_cond_switch_free : ∀l.∀H:branches_switch_free l.∀e,lab,u.switch_free (\fst (\fst (produce_cond e l u lab))).
254#l @(labeled_statements_ind … l)
255[ 1: #s #Hsf #e #lab #u normalize cases (fresh ??) #lab0 #u1
256     normalize in Hsf ⊢ %; @(convert_break_lift … Hsf)
257| 2: #sz #i #hd #tl #Hind whd in ⊢ (% → ?); * #Hsf_hd #Hsf_tl
258     #e #lab #u normalize
259     lapply (Hind Hsf_tl e lab u)
260     cases (produce_cond e tl u lab) * #cond #lab' #u' #Hsf normalize nodelta
261     cases (fresh ??) #lab0 #u2 normalize nodelta
262     normalize try @conj try @conj try @conj try //
263     @(convert_break_lift … Hsf_hd)
264] qed.
265
266lemma simplify_switch_switch_free : ∀e,l. ∀H:branches_switch_free l. ∀u. switch_free (\fst (simplify_switch e l u)).
267#e #l cases l
268[ 1: #def normalize #H #u cases (fresh ? u) #exit_label #uv normalize cases (fresh ? uv) #lab #uv' normalize nodelta
269     whd @conj whd
270     [ 1: @convert_break_lift assumption
271     | 2: @I ]
272| 2: #sz #i #case #tl normalize * #Hsf #Hsftl #u
273     cases (fresh ? u) #exit_label #uv1 normalize nodelta
274     lapply (produce_cond_switch_free tl Hsftl e exit_label uv1)
275     cases (produce_cond e tl uv1 exit_label)
276     * #cond #lab #u1 #Hsf_cond normalize nodelta
277     cases (fresh ??) #lab0 #u2 normalize nodelta
278     normalize @conj try @conj try @conj try @conj try //
279     @(convert_break_lift ?? Hsf)
280] qed.
281
282(* Instead of using tuples, we use a special type to pack the results of [switch_removal]. We do that in
283   order to circumvent the associativity problems in notations. *)
284record swret (A : Type[0]) : Type[0] ≝ {
285  ret_st  : A;
286  ret_acc : list (ident × type);
287  ret_fvs : list ident;
288  ret_u   : universe SymbolTag
289}.
290
291notation > "vbox('do' 〈ident v1, ident v2, ident v3, ident v4〉 ← e; break e')" with precedence 48
292for @{ match ${e} with
293       [ None ⇒ None ?
294       | Some ${fresh ret} ⇒
295          (λ${ident v1}.λ${ident v2}.λ${ident v3}.λ${ident v4}. ${e'})
296          (ret_st ? ${fresh ret})
297          (ret_acc ? ${fresh ret})
298          (ret_fvs ? ${fresh ret})
299          (ret_u ? ${fresh ret}) ] }.
300
301notation > "vbox('ret' 〈e1, e2, e3, e4〉)" with precedence 49
302for @{ Some ? (mk_swret ? ${e1} ${e2} ${e3} ${e4})  }.
303     
304(* Recursively convert a statement into a switch-free one. We /provide/ directly to the function a list
305   of identifiers (supposedly fresh). The actual task of producing this identifier is decoupled in another
306   'twin' function. It is then proved that feeding [switch_removal] with the correct amount of free variables
307   allows it to proceed without failing. This is all in order to ease the proof of simulation. *)
308let rec switch_removal
309  (st : statement)           (* the statement in which we will remove switches *)
310  (fvs : list ident)         (* a finite list of names usable to create variables. *)
311  (u : universe SymbolTag)   (* a fresh /label/ generator *)
312  : option (swret statement) ≝
313match st with
314[ Sskip       ⇒ ret 〈st, [ ], fvs, u〉
315| Sassign _ _ ⇒ ret 〈st, [ ], fvs, u〉
316| Scall _ _ _ ⇒ ret 〈st, [ ], fvs, u〉
317| Ssequence s1 s2 ⇒
318  do 〈s1', acc1, fvs', u'〉 ← switch_removal s1 fvs u;
319  do 〈s2', acc2, fvs'', u''〉 ← switch_removal s2 fvs' u';
320  ret 〈Ssequence s1' s2', acc1 @ acc2, fvs'', u''〉
321| Sifthenelse e s1 s2 ⇒
322  do 〈s1', acc1, fvs', u'〉 ← switch_removal s1 fvs u;
323  do 〈s2', acc2, fvs'', u''〉 ← switch_removal s2 fvs' u';
324  ret 〈Sifthenelse e s1' s2', acc1 @ acc2, fvs'', u''〉
325| Swhile e body ⇒
326  do 〈body', acc, fvs', u'〉 ← switch_removal body fvs u;
327  ret 〈Swhile e body', acc, fvs', u'〉
328| Sdowhile e body ⇒
329  do 〈body', acc, fvs', u'〉 ← switch_removal body fvs u;
330  ret 〈Sdowhile e body', acc, fvs', u'〉
331| Sfor s1 e s2 s3 ⇒
332  do 〈s1', acc1, fvs', u'〉 ← switch_removal s1 fvs u;
333  do 〈s2', acc2, fvs'', u''〉 ← switch_removal s2 fvs' u';
334  do 〈s3', acc3, fvs''', u'''〉 ← switch_removal s3 fvs'' u'';
335  ret 〈Sfor s1' e s2' s3', acc1 @ acc2 @ acc3, fvs''', u'''〉
336| Sbreak ⇒
337  ret 〈st, [ ], fvs, u〉
338| Scontinue ⇒
339  ret 〈st, [ ], fvs, u〉
340| Sreturn _ ⇒
341  ret 〈st, [ ], fvs, u〉
342| Sswitch e branches ⇒   
343   do 〈sf_branches, acc, fvs', u'〉 ← switch_removal_branches branches fvs u;
344   match fvs' with
345   [ nil ⇒ None ?
346   | cons fresh tl ⇒
347     (* let 〈switch_tmp, uv2〉 ≝ fresh ? uv1 in *)
348     let ident         ≝ Expr (Evar fresh) (typeof e) in
349     let assign        ≝ Sassign ident e in
350     let 〈result, u''〉 ≝ simplify_switch ident sf_branches u' in
351       ret 〈Ssequence assign result, (〈fresh, typeof e〉 :: acc), tl, u'〉
352   ]
353| Slabel label body ⇒
354  do 〈body', acc, fvs', u'〉 ← switch_removal body fvs u;
355  ret 〈Slabel label body', acc, fvs', u'〉
356| Sgoto _ ⇒
357  ret 〈st, [ ], fvs, u〉
358| Scost cost body ⇒
359  do 〈body', acc, fvs', u'〉 ← switch_removal body fvs u;
360  ret 〈Scost cost body', acc, fvs', u'〉
361]
362
363and switch_removal_branches
364  (l : labeled_statements)
365  (fvs : list ident)
366  (u : universe SymbolTag)
367(*  : option (labeled_statements × (list (ident × type)) × (list ident) × (universe SymbolTag)) *) ≝
368match l with
369[ LSdefault st ⇒
370  do 〈st', acc1, fvs', u'〉 ← switch_removal st fvs u;
371  ret 〈LSdefault st', acc1, fvs', u'〉
372| LScase sz int st tl =>
373  do 〈tl_result, acc1, fvs', u'〉 ← switch_removal_branches tl fvs u;
374  do 〈st', acc2, fvs'', u''〉 ← switch_removal st fvs' u';
375  ret 〈LScase sz int st' tl_result, acc1 @ acc2, fvs'', u''〉
376].
377
378let rec mk_fresh_variables
379  (st : statement)           (* the statement in which we will remove switches *)
380  (u : universe SymbolTag)   (* a fresh /label/ generator *)
381  : (list ident) × (universe SymbolTag) ≝
382match st with
383[ Sskip       ⇒ 〈[ ], u〉
384| Sassign _ _ ⇒ 〈[ ], u〉
385| Scall _ _ _ ⇒ 〈[ ], u〉
386| Ssequence s1 s2 ⇒
387  let 〈fvs, u'〉 ≝ mk_fresh_variables s1 u in
388  let 〈fvs', u''〉 ≝ mk_fresh_variables s2 u' in
389  〈fvs @ fvs', u''〉
390| Sifthenelse e s1 s2 ⇒
391  let 〈fvs, u'〉 ≝ mk_fresh_variables s1 u in
392  let 〈fvs', u''〉 ≝ mk_fresh_variables s2 u' in
393  〈fvs @ fvs', u''〉
394| Swhile e body ⇒
395  mk_fresh_variables body u
396| Sdowhile e body ⇒
397  mk_fresh_variables body u
398| Sfor s1 e s2 s3 ⇒
399  let 〈fvs, u'〉 ≝ mk_fresh_variables s1 u in
400  let 〈fvs', u''〉 ≝ mk_fresh_variables s2 u' in
401  let 〈fvs'', u'''〉 ≝ mk_fresh_variables s3 u'' in
402  〈fvs @ fvs' @fvs'', u'''〉
403| Sbreak ⇒
404  〈[ ], u〉
405| Scontinue ⇒
406  〈[ ], u〉
407| Sreturn _ ⇒
408  〈[ ], u〉
409| Sswitch e branches ⇒   
410   let 〈ident, u'〉 ≝ fresh ? u in (* This is actually the only point where we need to create a fresh var. *)
411   let 〈fvs, u''〉 ≝ mk_fresh_variables_branches branches u' in
412   〈fvs @ [ident], u''〉  (* reversing the order to match a proof invariant *)
413| Slabel label body ⇒
414  mk_fresh_variables body u
415| Sgoto _ ⇒
416  〈[ ], u〉
417| Scost cost body ⇒
418  mk_fresh_variables body u
419]
420
421and mk_fresh_variables_branches
422  (l : labeled_statements)
423  (u : universe SymbolTag)
424(*  : option (labeled_statements × (list (ident × type)) × (list ident) × (universe SymbolTag)) *) ≝
425match l with
426[ LSdefault st ⇒
427  mk_fresh_variables st u
428| LScase sz int st tl =>
429  let 〈fvs, u'〉 ≝ mk_fresh_variables_branches tl u in
430  let 〈fvs',u''〉 ≝ mk_fresh_variables st u' in
431  〈fvs @ fvs', u''〉
432].
433
434(* Copied this from Csyntax.ma, lifted from Prop to Type
435   (I needed to eliminate something proved with this towards Type)  *)
436let rec statement_indT
437  (P:statement → Type[1]) (Q:labeled_statements → Type[1])
438  (Ssk:P Sskip)
439  (Sas:∀e1,e2. P (Sassign e1 e2))
440  (Sca:∀eo,e,args. P (Scall eo e args))
441  (Ssq:∀s1,s2. P s1 → P s2 → P (Ssequence s1 s2))
442  (Sif:∀e,s1,s2. P s1 → P s2 → P (Sifthenelse e s1 s2))
443  (Swh:∀e,s. P s → P (Swhile e s))
444  (Sdo:∀e,s. P s → P (Sdowhile e s))
445  (Sfo:∀s1,e,s2,s3. P s1 → P s2 → P s3 → P (Sfor s1 e s2 s3))
446  (Sbr:P Sbreak)
447  (Sco:P Scontinue)
448  (Sre:∀eo. P (Sreturn eo))
449  (Ssw:∀e,ls. Q ls → P (Sswitch e ls))
450  (Sla:∀l,s. P s → P (Slabel l s))
451  (Sgo:∀l. P (Sgoto l))
452  (Scs:∀l,s. P s → P (Scost l s))
453  (LSd:∀s. P s → Q (LSdefault s))
454  (LSc:∀sz,i,s,t. P s → Q t → Q (LScase sz i s t))
455  (s:statement) on s : P s ≝
456match s with
457[ Sskip ⇒ Ssk
458| Sassign e1 e2 ⇒ Sas e1 e2
459| Scall eo e args ⇒ Sca eo e args
460| Ssequence s1 s2 ⇒ Ssq s1 s2
461    (statement_indT P Q Ssk Sas Sca Ssq Sif Swh Sdo Sfo Sbr Sco Sre Ssw Sla Sgo Scs LSd LSc s1)
462    (statement_indT P Q Ssk Sas Sca Ssq Sif Swh Sdo Sfo Sbr Sco Sre Ssw Sla Sgo Scs LSd LSc s2)
463| Sifthenelse e s1 s2 ⇒ Sif e s1 s2
464    (statement_indT P Q Ssk Sas Sca Ssq Sif Swh Sdo Sfo Sbr Sco Sre Ssw Sla Sgo Scs LSd LSc s1)
465    (statement_indT P Q Ssk Sas Sca Ssq Sif Swh Sdo Sfo Sbr Sco Sre Ssw Sla Sgo Scs LSd LSc s2)
466| Swhile e s ⇒ Swh e s
467    (statement_indT P Q Ssk Sas Sca Ssq Sif Swh Sdo Sfo Sbr Sco Sre Ssw Sla Sgo Scs LSd LSc s)
468| Sdowhile e s ⇒ Sdo e s
469    (statement_indT P Q Ssk Sas Sca Ssq Sif Swh Sdo Sfo Sbr Sco Sre Ssw Sla Sgo Scs LSd LSc s)
470| Sfor s1 e s2 s3 ⇒ Sfo s1 e s2 s3
471    (statement_indT P Q Ssk Sas Sca Ssq Sif Swh Sdo Sfo Sbr Sco Sre Ssw Sla Sgo Scs LSd LSc s1)
472    (statement_indT P Q Ssk Sas Sca Ssq Sif Swh Sdo Sfo Sbr Sco Sre Ssw Sla Sgo Scs LSd LSc s2)
473    (statement_indT P Q Ssk Sas Sca Ssq Sif Swh Sdo Sfo Sbr Sco Sre Ssw Sla Sgo Scs LSd LSc s3)
474| Sbreak ⇒ Sbr
475| Scontinue ⇒ Sco
476| Sreturn eo ⇒ Sre eo
477| Sswitch e ls ⇒ Ssw e ls
478    (labeled_statements_indT P Q Ssk Sas Sca Ssq Sif Swh Sdo Sfo Sbr Sco Sre Ssw Sla Sgo Scs LSd LSc ls)
479| Slabel l s ⇒ Sla l s
480    (statement_indT P Q Ssk Sas Sca Ssq Sif Swh Sdo Sfo Sbr Sco Sre Ssw Sla Sgo Scs LSd LSc s)
481| Sgoto l ⇒ Sgo l
482| Scost l s ⇒ Scs l s
483    (statement_indT P Q Ssk Sas Sca Ssq Sif Swh Sdo Sfo Sbr Sco Sre Ssw Sla Sgo Scs LSd LSc s)
484]
485and labeled_statements_indT
486  (P:statement → Type[1]) (Q:labeled_statements → Type[1])
487  (Ssk:P Sskip)
488  (Sas:∀e1,e2. P (Sassign e1 e2))
489  (Sca:∀eo,e,args. P (Scall eo e args))
490  (Ssq:∀s1,s2. P s1 → P s2 → P (Ssequence s1 s2))
491  (Sif:∀e,s1,s2. P s1 → P s2 → P (Sifthenelse e s1 s2))
492  (Swh:∀e,s. P s → P (Swhile e s))
493  (Sdo:∀e,s. P s → P (Sdowhile e s))
494  (Sfo:∀s1,e,s2,s3. P s1 → P s2 → P s3 → P (Sfor s1 e s2 s3))
495  (Sbr:P Sbreak)
496  (Sco:P Scontinue)
497  (Sre:∀eo. P (Sreturn eo))
498  (Ssw:∀e,ls. Q ls → P (Sswitch e ls))
499  (Sla:∀l,s. P s → P (Slabel l s))
500  (Sgo:∀l. P (Sgoto l))
501  (Scs:∀l,s. P s → P (Scost l s))
502  (LSd:∀s. P s → Q (LSdefault s))
503  (LSc:∀sz,i,s,t. P s → Q t → Q (LScase sz i s t))
504  (ls:labeled_statements) on ls : Q ls ≝
505match ls with
506[ LSdefault s ⇒ LSd s
507    (statement_indT P Q Ssk Sas Sca Ssq Sif Swh Sdo Sfo Sbr Sco Sre Ssw Sla Sgo Scs LSd LSc s)
508| LScase sz i s t ⇒ LSc sz i s t
509    (statement_indT P Q Ssk Sas Sca Ssq Sif Swh Sdo Sfo Sbr Sco Sre Ssw Sla Sgo Scs LSd LSc s)
510    (labeled_statements_indT P Q Ssk Sas Sca Ssq Sif Swh Sdo Sfo Sbr Sco Sre Ssw Sla Sgo Scs LSd LSc t)
511].
512
513lemma switch_removal_ok :
514  ∀st, u0, u1, post.
515  Σresult.
516  (switch_removal st ((\fst (mk_fresh_variables st u0)) @ post) u1 = Some ? result) ∧ (ret_fvs ? result = post).
517#st
518@(statement_indT ? (λls. ∀u0, u1, post.
519                          Σresult.
520                          (switch_removal_branches ls ((\fst (mk_fresh_variables_branches ls u0)) @ post) u1 = Some ? result)
521                          ∧ (ret_fvs ? result = post)
522                   ) … st)
523[ 1: #u0 #u1 #post normalize
524     %{(mk_swret statement Sskip [] post u1)} % //
525| 2: #e1 #e2 #u0 #u1 #post normalize
526     %{((mk_swret statement (Sassign e1 e2) [] post u1))} % try //
527| 3: #e0 #e #args #u0 #u1 #post normalize
528     %{(mk_swret statement (Scall e0 e args) [] post u1)} % try //
529| 4: #s1 #s2 #H1 #H2 #u0 #u1 #post normalize
530     elim (H1 u0 u1 ((\fst  (mk_fresh_variables s2 (\snd (mk_fresh_variables s1 u0)))) @ post)) #s1' *     
531     cases (mk_fresh_variables s1 u0) #fvs #u' normalize nodelta
532     elim (H2 u' (ret_u ? s1') post) #s2' *
533     cases (mk_fresh_variables s2 u') #fvs' #u'' normalize nodelta
534     #Heq2 #Heq2_fvs #Heq1 #Heq1_fvs >associative_append >Heq1 normalize nodelta >Heq1_fvs >Heq2 normalize
535     %{(mk_swret statement (Ssequence (ret_st statement s1') (ret_st statement s2'))
536        (ret_acc statement s1'@ret_acc statement s2') (ret_fvs statement s2')
537        (ret_u statement s2'))} % try //
538| 5: #e #s1 #s2 #H1 #H2 #u0 #u1 #post normalize
539     elim (H1 u0 u1 ((\fst  (mk_fresh_variables s2 (\snd (mk_fresh_variables s1 u0)))) @ post)) #s1' *     
540     cases (mk_fresh_variables s1 u0) #fvs #u' normalize nodelta
541     elim (H2 u' (ret_u ? s1') post) #s2' *
542     cases (mk_fresh_variables s2 u') #fvs' #u'' normalize nodelta
543     #Heq2 #Heq2_fvs #Heq1 #Heq1_fvs >associative_append >Heq1 normalize nodelta >Heq1_fvs >Heq2 normalize
544     %{((mk_swret statement
545         (Sifthenelse e (ret_st statement s1') (ret_st statement s2'))
546         (ret_acc statement s1'@ret_acc statement s2') (ret_fvs statement s2')
547         (ret_u statement s2')))} % try //
548| 6: #e #s #H #u0 #u1 #post normalize
549     elim (H u0 u1 post) #s1' * normalize
550     cases (mk_fresh_variables s u0) #fvs #u'
551     #Heq1 #Heq1_fvs >Heq1 normalize nodelta
552     %{(mk_swret statement (Swhile e (ret_st statement s1')) (ret_acc statement s1')
553        (ret_fvs statement s1') (ret_u statement s1'))} % try //
554| 7: #e #s #H #u0 #u1 #post normalize
555     elim (H u0 u1 post) #s1' * normalize
556     cases (mk_fresh_variables s u0) #fvs #u'
557     #Heq1 #Heq1_fvs >Heq1 normalize nodelta
558     %{(mk_swret statement (Sdowhile e (ret_st statement s1')) (ret_acc statement s1')
559        (ret_fvs statement s1') (ret_u statement s1'))} % try //
560| 8: #s1 #e #s2 #s3 #H1 #H2 #H3 #u0 #u1 #post normalize
561     elim (H1 u0 u1
562                (\fst (mk_fresh_variables s2 (\snd  (mk_fresh_variables s1 u0))) @
563                (\fst (mk_fresh_variables s3 (\snd  (mk_fresh_variables s2 (\snd (mk_fresh_variables s1 u0)))))) @
564                post)) #s1' *
565     cases (mk_fresh_variables s1 u0) #fvs #u' normalize nodelta
566     elim (H2 u' (ret_u ? s1') ((\fst (mk_fresh_variables s3 (\snd  (mk_fresh_variables s2 u')))) @
567                                 post)) #s2' *
568     cases (mk_fresh_variables s2 u') #fvs' #u'' normalize nodelta
569     elim (H3 u'' (ret_u ? s2') post) #s3' *
570     cases (mk_fresh_variables s3 u'') #fvs'' #u''' normalize nodelta
571     #Heq3 #Heq3_fvs #Heq2 #Heq2_fvs #Heq1 #Heq1_fvs
572     >associative_append >associative_append >Heq1 normalize >Heq1_fvs
573     >Heq2 normalize >Heq2_fvs >Heq3 normalize
574     %{(mk_swret statement
575        (Sfor (ret_st statement s1') e (ret_st statement s2') (ret_st statement s3'))
576        (ret_acc statement s1'@ret_acc statement s2'@ret_acc statement s3')
577        (ret_fvs statement s3') (ret_u statement s3'))} % try //
578| 9:  #u0 #u1 #post normalize %{(mk_swret statement Sbreak [] post u1)} % //
579| 10: #u0 #u1 #post normalize %{(mk_swret statement Scontinue [] post u1)} % //
580| 11: #e #u0 #u1 #post normalize %{(mk_swret statement (Sreturn e) [] post u1)} % //
581| 12: #e #ls #H #u0 #u1 #post
582      whd in match (mk_fresh_variables ??);
583      whd in match (switch_removal ???);     
584      elim (fresh ? u0) #fresh #u'
585      elim (H u' u1 ([fresh] @ post)) #ls' * normalize nodelta
586      cases (mk_fresh_variables_branches ls u') #fvs #u'' normalize nodelta     
587      >associative_append #Heq #Heq_fvs >Heq normalize nodelta
588      >Heq_fvs normalize nodelta
589      cases (simplify_switch ???) #st' #u''' normalize nodelta
590      %{((mk_swret statement
591          (Ssequence (Sassign (Expr (Evar fresh) (typeof e)) e) st')
592          (〈fresh,typeof e〉::ret_acc labeled_statements ls') ([]@post)
593          (ret_u labeled_statements ls')))} % //
594| 13: #l #s #H #u0 #u1 #post normalize
595      elim (H u0 u1 post) #s' * #Heq >Heq normalize nodelta #Heq_fvs >Heq_fvs
596      %{(mk_swret statement (Slabel l (ret_st statement s')) (ret_acc statement s')
597           post (ret_u statement s'))} % //
598| 14: #l #u0 #u1 #post normalize %{((mk_swret statement (Sgoto l) [] post u1))} % //
599| 15: #l #s #H #u0 #u1 #post normalize
600      elim (H u0 u1 post) #s' * #Heq >Heq normalize nodelta #Heq_fvs >Heq_fvs
601      %{(mk_swret statement (Scost l (ret_st statement s')) (ret_acc statement s')
602           post (ret_u statement s'))} % //
603| 16: #s #H #u0 #u1 #post normalize
604      elim (H u0 u1 post) #s' * #Heq >Heq normalize nodelta #Heq_fvs >Heq_fvs
605      %{(mk_swret labeled_statements (LSdefault (ret_st statement s'))
606         (ret_acc statement s') post (ret_u statement s'))} % //
607| 17: #sz #i #hd #tl #H1 #H2 #u0 #u1 #post normalize
608      elim (H2 u0 u1 (\fst (mk_fresh_variables hd (\snd (mk_fresh_variables_branches tl u0))) @ post)) #ls' *
609      cases (mk_fresh_variables_branches tl u0) #fvs #u' normalize
610      elim (H1 u' (ret_u labeled_statements ls') post) #s1' *
611      cases (mk_fresh_variables hd u') #fvs' #u' normalize #Heq #Heq_fvs #Heql #Heql_fvs
612      >associative_append >Heql normalize >Heql_fvs >Heq normalize
613      %{(mk_swret labeled_statements
614          (LScase sz i (ret_st statement s1') (ret_st labeled_statements ls'))
615          (ret_acc labeled_statements ls'@ret_acc statement s1')
616          (ret_fvs statement s1') (ret_u statement s1'))} % //
617] qed.
618
619axiom cthulhu : ∀A:Prop. A. (* Because of the nightmares. *)
620
621(* Proof that switch_removal_switch_free does its job. *)
622lemma switch_removal_switch_free : ∀st,fvs,u,result. switch_removal st fvs u = Some ? result → switch_free (ret_st ? result).
623#st @(statement_ind2 ? (λls. ∀fvs,u,ls_result. switch_removal_branches ls fvs u = Some ? ls_result →
624                                                 branches_switch_free (ret_st ? ls_result)) … st)
625[ 1: #fvs #u #result normalize #Heq destruct (Heq) //
626| 2: #e1 #e2 #fvs #u #result normalize #Heq destruct (Heq) //
627| 3: #e0 #e #args #fvs #u #result normalize #Heq destruct (Heq) //
628| 4: #s1 #s2 #H1 #H2 #fvs #u #result normalize lapply (H1 fvs u)
629     elim (switch_removal s1 fvs u) normalize
630     [ 1: #_ #Habsurd destruct (Habsurd)
631     | 2: #res1 #Heq1 lapply (H2 (ret_fvs statement res1) (ret_u statement res1))
632          elim (switch_removal s2 (ret_fvs statement res1) (ret_u statement res1))
633          [ 1: normalize #_ #Habsurd destruct (Habsurd)
634          | 2: normalize #res2 #Heq2 #Heq destruct (Heq)
635               normalize @conj
636               [ 1: @Heq1 // | 2: @Heq2 // ]
637     ] ]
638| *:
639  (* TODO the first few cases show that the lemma is routinely proved. TBF later. *)
640  @cthulhu ]
641qed.
642
643(* -----------------------------------------------------------------------------
644   Switch-removal code for programs.
645   ----------------------------------------------------------------------------*) 
646
647(* The functions in fresh.ma do not consider labels. Using [universe_for_program p] may lead to
648 * name clashes for labels. We have no choice but to actually run through the function and to
649 * compute the maximum of labels+identifiers. This way we can generate both fresh variables and
650 * fresh labels using the same univ. While we're at it we also consider record fields.
651 * Cost labels are not considered, though. They already live in a separate universe.
652 *
653 * Important note: this is partially redundant with fresh.ma. We take care of avoiding name clashes,
654 * but in the end it might be good to move the following functions into fresh.ma.
655 *)
656
657(* Least element in the total order of identifiers. *)
658definition least_identifier ≝ an_identifier SymbolTag one.
659
660(* This is certainly overkill: variables adressed in an expression should be declared in the
661 * enclosing function's prototype. *)
662let rec max_of_expr (e : expr) : ident ≝
663match e with
664[ Expr ed _ ⇒
665  match ed with
666  [ Econst_int _ _ ⇒ least_identifier
667  | Econst_float _ ⇒ least_identifier
668  | Evar id ⇒ id
669  | Ederef e1 ⇒ max_of_expr e1
670  | Eaddrof e1 ⇒ max_of_expr e1
671  | Eunop _ e1 ⇒ max_of_expr e1
672  | Ebinop _ e1 e2 ⇒ max_id (max_of_expr e1) (max_of_expr e2)
673  | Ecast _ e1 ⇒ max_of_expr e1
674  | Econdition e1 e2 e3 ⇒ 
675    max_id (max_of_expr e1) (max_id (max_of_expr e2) (max_of_expr e3))
676  | Eandbool e1 e2 ⇒
677    max_id (max_of_expr e1) (max_of_expr e2)
678  | Eorbool e1 e2 ⇒
679    max_id (max_of_expr e1) (max_of_expr e2) 
680  | Esizeof _ ⇒ least_identifier
681  | Efield r f ⇒ max_id f (max_of_expr r)
682  | Ecost _ e1 ⇒ max_of_expr e1
683  ]
684].
685
686(* Reasoning about this promises to be a serious pain. Especially the Scall case. *)
687let rec max_of_statement (s : statement) : ident ≝
688match s with
689[ Sskip ⇒ least_identifier
690| Sassign e1 e2 ⇒ max_id (max_of_expr e1) (max_of_expr e2)
691| Scall r f args ⇒
692  let retmax ≝
693    match r with
694    [ None ⇒ least_identifier
695    | Some e ⇒ max_of_expr e ]
696  in
697  max_id (max_of_expr f)
698         (max_id retmax
699                 (foldl ?? (λacc,elt. max_id (max_of_expr elt) acc) least_identifier args) )
700| Ssequence s1 s2 ⇒
701  max_id (max_of_statement s1) (max_of_statement s2)
702| Sifthenelse e s1 s2 ⇒
703  max_id (max_of_expr e) (max_id (max_of_statement s1) (max_of_statement s2))
704| Swhile e body ⇒
705  max_id (max_of_expr e) (max_of_statement body)
706| Sdowhile e body ⇒
707  max_id (max_of_expr e) (max_of_statement body)
708| Sfor init test incr body ⇒
709  max_id (max_id (max_of_statement init) (max_of_expr test)) (max_id (max_of_statement incr) (max_of_statement body))
710| Sbreak ⇒ least_identifier
711| Scontinue ⇒ least_identifier
712| Sreturn opt ⇒
713  match opt with
714  [ None ⇒ least_identifier
715  | Some e ⇒ max_of_expr e
716  ]
717| Sswitch e ls ⇒
718  max_id (max_of_expr e) (max_of_ls ls)
719| Slabel lab body ⇒
720  max_id lab (max_of_statement body)
721| Sgoto lab ⇒
722  lab
723| Scost _ body ⇒
724  max_of_statement body
725]
726and max_of_ls (ls : labeled_statements) : ident ≝
727match ls with
728[ LSdefault s ⇒ max_of_statement s
729| LScase _ _ s ls' ⇒ max_id (max_of_ls ls') (max_of_statement s)
730].
731
732definition max_id_of_function : function → ident ≝
733λf. max_id (max_of_statement (fn_body f)) (max_id_of_fn f).
734
735(* We compute fresh universes on a function-by function basis, since there can't
736 * be cross-functions gotos or stuff like that. *)
737definition function_switch_removal : function → function × (list (ident × type)) ≝
738λf.
739  (λres_record.
740    let new_vars ≝ ret_acc ? res_record in
741    let result ≝ mk_function (fn_return f) (fn_params f) (new_vars @ (fn_vars f)) (ret_st ? res_record) in
742    〈result, new_vars〉)
743  (let u ≝ universe_of_max (max_id_of_function f) in
744   let 〈fvs,u'〉 as Hfv ≝ mk_fresh_variables (fn_body f) u in
745   match switch_removal (fn_body f) fvs u' return λx. (switch_removal (fn_body f) fvs u' = x) → ? with
746   [ None ⇒ λHsr. ?
747   | Some res_record ⇒ λ_. res_record
748   ] (refl ? (switch_removal (fn_body f) fvs u'))).   
749lapply (switch_removal_ok (fn_body f) u u' [ ]) * #result' * #Heq #Hret_eq
750<Hfv in Heq; >append_nil >Hsr #Habsurd destruct (Habsurd)
751qed.
752
753let rec fundef_switch_removal (f : clight_fundef) : clight_fundef ≝
754match f with
755[ CL_Internal f ⇒
756  CL_Internal (\fst (function_switch_removal f))
757| CL_External _ _ _ ⇒
758  f
759].
760
761let rec program_switch_removal (p : clight_program) : clight_program ≝
762 let prog_funcs ≝ prog_funct ?? p in
763 let sf_funcs   ≝ map ?? (λcl_fundef.
764    let 〈fun_id, fun_def〉 ≝ cl_fundef in
765    〈fun_id, fundef_switch_removal fun_def〉
766  ) prog_funcs in
767 mk_program ??
768  (prog_vars … p)
769  sf_funcs
770  (prog_main … p).
771
772
773(* -----------------------------------------------------------------------------
774   Applying two relations on all substatements and all subexprs (directly under).
775   ---------------------------------------------------------------------------- *)
776
777let rec substatement_P (s1 : statement) (P : statement → Prop) (Q : expr → Prop) : Prop ≝
778match s1 with
779[ Sskip ⇒ True
780| Sassign e1 e2 ⇒ Q e1 ∧ Q e2
781| Scall r f args ⇒
782  match r with
783  [ None ⇒ Q f ∧ (All … Q args)
784  | Some r ⇒ Q r ∧ Q f ∧ (All … Q args)
785  ]
786| Ssequence sub1 sub2 ⇒ P sub1 ∧ P sub2
787| Sifthenelse e sub1 sub2 ⇒ P sub1 ∧ P sub2
788| Swhile e sub ⇒ Q e ∧ P sub
789| Sdowhile e sub ⇒ Q e ∧ P sub
790| Sfor sub1 cond sub2 sub3 ⇒ P sub1 ∧ Q cond ∧ P sub2 ∧ P sub3
791| Sbreak ⇒ True
792| Scontinue ⇒ True
793| Sreturn r ⇒
794  match r with
795  [ None ⇒ True
796  | Some r ⇒ Q r ]
797| Sswitch e ls ⇒ Q e ∧ (substatement_ls ls P)
798| Slabel _ sub ⇒ P sub
799| Sgoto _ ⇒ True
800| Scost _ sub ⇒ P sub
801]
802and substatement_ls ls (P : statement → Prop) : Prop ≝
803match ls with
804[ LSdefault sub ⇒ P sub
805| LScase _ _ sub tl ⇒ P sub ∧ (substatement_ls tl P)
806].
807
808(* -----------------------------------------------------------------------------
809   Freshness conservation results on switch removal.
810   ---------------------------------------------------------------------------- *)
811
812(* Similar stuff in toCminor.ma. *)
813lemma fresh_for_univ_still_fresh :
814   ∀u,i. fresh_for_univ SymbolTag i u → ∀v,u'. 〈v, u'〉 = fresh ? u → fresh_for_univ ? i u'.
815* #p * #i #H1 #v * #p' lapply H1 normalize
816#H1 #H2 destruct (H2) /2/ qed.
817
818lemma fresh_eq : ∀u,i. fresh_for_univ SymbolTag i u → ∃fv,u'. fresh ? u = 〈fv, u'〉 ∧ fresh_for_univ ? i u'.
819#u #i #Hfresh lapply (fresh_for_univ_still_fresh … Hfresh)
820cases (fresh SymbolTag u)
821#fv #u' #H %{fv} %{u'} @conj try // @H //
822qed.
823
824lemma produce_cond_fresh : ∀e,exit,ls,u,i. fresh_for_univ ? i u → fresh_for_univ ? i (\snd (produce_cond e ls u exit)).
825#e #exit #ls @(branches_ind … ls)
826[ 1: #st #u #i #Hfresh normalize
827     lapply (fresh_for_univ_still_fresh … Hfresh)
828     cases (fresh ? u) #lab #u1 #H lapply (H lab u1 (refl ??)) normalize //
829| 2: #sz #i #hd #tl #Hind #u #i' #Hfresh normalize
830     lapply (Hind u i' Hfresh) elim (produce_cond e tl u exit) *
831     #subcond #sublabel #u1 #Hfresh1 normalize
832     lapply (fresh_for_univ_still_fresh … Hfresh1)
833     cases (fresh ? u1) #lab #u2 #H2 lapply (H2 lab u2 (refl ??)) normalize //
834] qed.
835
836lemma simplify_switch_fresh : ∀u,i,e,ls.
837 fresh_for_univ ? i u →
838 fresh_for_univ ? i (\snd (simplify_switch e ls u)).
839#u #i #e #ls #Hfresh
840normalize
841lapply (fresh_for_univ_still_fresh … Hfresh)
842cases (fresh ? u)
843#exit_label #uv1 #Haux lapply (Haux exit_label uv1 (refl ??)) -Haux #Haux
844normalize lapply (produce_cond_fresh e exit_label ls … Haux)
845elim (produce_cond ????) * #stm #label #uv2 normalize nodelta //
846qed.
847
848(*
849lemma switch_removal_fresh : ∀i,s,u.
850    fresh_for_univ ? i u →
851    fresh_for_univ ? i (\snd (switch_removal s u)).
852#i #s @(statement_ind2 ? (λls. ∀u. fresh_for_univ ? i u →
853                                      fresh_for_univ ? i (\snd (switch_removal_branches ls u))) … s)
854try //
855[ 1: #s1' #s2' #Hind1 #Hind2 #u #Hyp
856     whd in match (switch_removal (Ssequence s1' s2') u);
857     lapply (Hind1 u Hyp) elim (switch_removal s1' u)
858     * #irr1 #irr2 #uA #HuA normalize nodelta
859     lapply (Hind2 uA HuA) elim (switch_removal s2' uA)
860     * #irr3 #irr4 #uB #HuB normalize nodelta //
861| 2: #e #s1' #s2' #Hind1 #Hind2 #u #Hyp
862     whd in match (switch_removal (Sifthenelse e s1' s2') u);
863     lapply (Hind1 u Hyp) elim (switch_removal s1' u)
864     * #irr1 #irr2 #uA #HuA normalize nodelta
865     lapply (Hind2 uA HuA) elim (switch_removal s2' uA)
866     * #irr3 #irr4 #uB #HuB normalize nodelta //
867| 3,4: #e #s' #Hind #u #Hyp
868     whd in match (switch_removal ? u);
869     lapply (Hind u Hyp) elim (switch_removal s' u)
870     * #irr1 #irr2 #uA #HuA normalize nodelta //
871| 5: #s1' #e #s2' #s3' #Hind1 #Hind2 #Hind3 #u #Hyp
872     whd in match (switch_removal (Sfor s1' e s2' s3') u);
873     lapply (Hind1 u Hyp) elim (switch_removal s1' u)
874     * #irr1 #irr2 #uA #HuA normalize nodelta
875     lapply (Hind2 uA HuA) elim (switch_removal s2' uA)
876     * #irr3 #irr4 #uB #HuB normalize nodelta
877     lapply (Hind3 uB HuB) elim (switch_removal s3' uB)
878     * #irr5 #irr6 #uC #HuC normalize nodelta //
879| 6: #e #ls #Hind #u #Hyp
880     whd in match (switch_removal (Sswitch e ls) u);
881     lapply (Hind u Hyp)
882     cases (switch_removal_branches ls u)
883     * #irr1 #irr2 #uA #HuA normalize nodelta
884     lapply (fresh_for_univ_still_fresh … HuA)
885     cases (fresh SymbolTag uA) #v #uA' #Haux lapply (Haux v uA' (refl ? 〈v,uA'〉))
886     -Haux #HuA' normalize nodelta
887     lapply (simplify_switch_fresh uA' i (Expr (Evar v) (typeof e)) irr1 HuA')
888     cases (simplify_switch ???) #stm #uB
889     #Haux normalize nodelta //
890| 7,8: #label #body #Hind #u #Hyp
891     whd in match (switch_removal ? u);
892     lapply (Hind u Hyp) elim (switch_removal body u)
893     * #irr1 #irr2 #uA #HuA normalize nodelta //
894| 9: #defcase #Hind #u #Hyp whd in match (switch_removal_branches ??);
895     lapply (Hind u Hyp) elim (switch_removal defcase u)
896     * #irr1 #irr2 #uA #HuA normalize nodelta //
897| 10: #sz #i0 #s0 #tl #Hind1 #Hind2 #u #Hyp normalize
898     lapply (Hind2 u Hyp) elim (switch_removal_branches tl u)
899     * #irr1 #irr2 #uA #HuA normalize nodelta
900     lapply (Hind1 uA HuA) elim (switch_removal s0 uA)
901     * #irr3 #irr4 #uB #HuB //
902] qed.
903
904lemma switch_removal_branches_fresh : ∀i,ls,u.
905    fresh_for_univ ? i u →
906    fresh_for_univ ? i (\snd (switch_removal_branches ls u)).
907#i #ls @(labeled_statements_ind2 (λs. ∀u. fresh_for_univ ? i u →
908                                           fresh_for_univ ? i (\snd (switch_removal s u))) ? … ls)
909try /2 by switch_removal_fresh/
910[ 1: #s #Hind #u #Hfresh normalize lapply (switch_removal_fresh ? s ? Hfresh)
911     cases (switch_removal s u) * //
912| 2: #sz #i #s #tl #Hs #Htl #u #Hfresh normalize
913     lapply (Htl u Hfresh)
914     cases (switch_removal_branches tl u) * normalize nodelta
915     #ls' #fvs #u' #Hfresh'
916     lapply (Hs u' Hfresh')
917     cases (switch_removal s u') * //
918] qed.
919*)
920(* -----------------------------------------------------------------------------
921   Simulation proof and related voodoo.
922   ----------------------------------------------------------------------------*)
923
924definition expr_lvalue_ind_combined ≝
925λP,Q,ci,cf,lv,vr,dr,ao,uo,bo,ca,cd,ab,ob,sz,fl,co,xx.
926conj ??
927 (expr_lvalue_ind P Q ci cf lv vr dr ao uo bo ca cd ab ob sz fl co xx)
928 (lvalue_expr_ind P Q ci cf lv vr dr ao uo bo ca cd ab ob sz fl co xx).
929 
930let rec expr_ind2
931    (P : expr → Prop) (Q : expr_descr → type → Prop)
932    (IE : ∀ed. ∀t. Q ed t → P (Expr ed t))
933    (Iconst_int : ∀sz, i, t. Q (Econst_int sz i) t)
934    (Iconst_float : ∀f, t. Q (Econst_float f) t)
935    (Ivar : ∀id, t. Q (Evar id) t)
936    (Ideref : ∀e, t. P e → Q (Ederef e) t)
937    (Iaddrof : ∀e, t. P e → Q (Eaddrof e) t)
938    (Iunop : ∀op,arg,t. P arg → Q (Eunop op arg) t)
939    (Ibinop : ∀op,arg1,arg2,t. P arg1 → P arg2 → Q (Ebinop op arg1 arg2) t)
940    (Icast : ∀castt, e, t. P e →  Q (Ecast castt e) t) 
941    (Icond : ∀e1,e2,e3,t. P e1 → P e2 → P e3 → Q (Econdition e1 e2 e3) t)
942    (Iandbool : ∀e1,e2,t. P e1 → P e2 → Q (Eandbool e1 e2) t)
943    (Iorbool : ∀e1,e2,t. P e1 → P e2 → Q (Eorbool e1 e2) t)
944    (Isizeof : ∀sizeoft,t. Q (Esizeof sizeoft) t)
945    (Ifield : ∀e,f,t. P e → Q (Efield e f) t)
946    (Icost : ∀c,e,t. P e → Q (Ecost c e) t)
947    (e : expr) on e : P e ≝
948match e with
949[ Expr ed t ⇒ IE ed t (expr_desc_ind2 P Q IE Iconst_int Iconst_float Ivar Ideref Iaddrof Iunop Ibinop Icast Icond Iandbool Iorbool Isizeof Ifield Icost ed t) ]
950
951and expr_desc_ind2
952    (P : expr → Prop) (Q : expr_descr → type → Prop)
953    (IE : ∀ed. ∀t. Q ed t → P (Expr ed t))
954    (Iconst_int : ∀sz, i, t. Q (Econst_int sz i) t)
955    (Iconst_float : ∀f, t. Q (Econst_float f) t)
956    (Ivar : ∀id, t. Q (Evar id) t)
957    (Ideref : ∀e, t. P e → Q (Ederef e) t)
958    (Iaddrof : ∀e, t. P e → Q (Eaddrof e) t)
959    (Iunop : ∀op,arg,t. P arg → Q (Eunop op arg) t)
960    (Ibinop : ∀op,arg1,arg2,t. P arg1 → P arg2 → Q (Ebinop op arg1 arg2) t)
961    (Icast : ∀castt, e, t. P e →  Q (Ecast castt e) t) 
962    (Icond : ∀e1,e2,e3,t. P e1 → P e2 → P e3 → Q (Econdition e1 e2 e3) t)
963    (Iandbool : ∀e1,e2,t. P e1 → P e2 → Q (Eandbool e1 e2) t)
964    (Iorbool : ∀e1,e2,t. P e1 → P e2 → Q (Eorbool e1 e2) t)
965    (Isizeof : ∀sizeoft,t. Q (Esizeof sizeoft) t)
966    (Ifield : ∀e,f,t. P e → Q (Efield e f) t)
967    (Icost : ∀c,e,t. P e → Q (Ecost c e) t)
968    (ed : expr_descr) (t : type) on ed : Q ed t ≝
969match ed with
970[ Econst_int sz i ⇒ Iconst_int sz i t
971| Econst_float f ⇒ Iconst_float f t
972| Evar id ⇒ Ivar id t
973| Ederef e ⇒ Ideref e t (expr_ind2 P Q IE Iconst_int Iconst_float Ivar Ideref Iaddrof Iunop Ibinop Icast Icond Iandbool Iorbool Isizeof Ifield Icost  e)
974| Eaddrof e ⇒ Iaddrof e t (expr_ind2 P Q IE Iconst_int Iconst_float Ivar Ideref Iaddrof Iunop Ibinop Icast Icond Iandbool Iorbool Isizeof Ifield Icost  e)
975| Eunop op e ⇒ Iunop op e t (expr_ind2 P Q IE Iconst_int Iconst_float Ivar Ideref Iaddrof Iunop Ibinop Icast Icond Iandbool Iorbool Isizeof Ifield Icost  e)
976| Ebinop op e1 e2 ⇒ Ibinop op e1 e2 t (expr_ind2 P Q IE Iconst_int Iconst_float Ivar Ideref Iaddrof Iunop Ibinop Icast Icond Iandbool Iorbool Isizeof Ifield Icost  e1) (expr_ind2 P Q IE Iconst_int Iconst_float Ivar Ideref Iaddrof Iunop Ibinop Icast Icond Iandbool Iorbool Isizeof Ifield Icost  e2)
977| Ecast castt e ⇒ Icast castt e t (expr_ind2 P Q IE Iconst_int Iconst_float Ivar Ideref Iaddrof Iunop Ibinop Icast Icond Iandbool Iorbool Isizeof Ifield Icost  e)
978| Econdition e1 e2 e3 ⇒ Icond e1 e2 e3 t (expr_ind2 P Q IE Iconst_int Iconst_float Ivar Ideref Iaddrof Iunop Ibinop Icast Icond Iandbool Iorbool Isizeof Ifield Icost  e1) (expr_ind2 P Q IE Iconst_int Iconst_float Ivar Ideref Iaddrof Iunop Ibinop Icast Icond Iandbool Iorbool Isizeof Ifield Icost  e2) (expr_ind2 P Q IE Iconst_int Iconst_float Ivar Ideref Iaddrof Iunop Ibinop Icast Icond Iandbool Iorbool Isizeof Ifield Icost  e3)
979| Eandbool e1 e2 ⇒ Iandbool e1 e2 t (expr_ind2 P Q IE Iconst_int Iconst_float Ivar Ideref Iaddrof Iunop Ibinop Icast Icond Iandbool Iorbool Isizeof Ifield Icost  e1) (expr_ind2 P Q IE Iconst_int Iconst_float Ivar Ideref Iaddrof Iunop Ibinop Icast Icond Iandbool Iorbool Isizeof Ifield Icost  e2)
980| Eorbool e1 e2 ⇒ Iorbool e1 e2 t (expr_ind2 P Q IE Iconst_int Iconst_float Ivar Ideref Iaddrof Iunop Ibinop Icast Icond Iandbool Iorbool Isizeof Ifield Icost  e1) (expr_ind2 P Q IE Iconst_int Iconst_float Ivar Ideref Iaddrof Iunop Ibinop Icast Icond Iandbool Iorbool Isizeof Ifield Icost  e2)
981| Esizeof sizeoft ⇒ Isizeof sizeoft t
982| Efield e field ⇒ Ifield e field t (expr_ind2 P Q IE Iconst_int Iconst_float Ivar Ideref Iaddrof Iunop Ibinop Icast Icond Iandbool Iorbool Isizeof Ifield Icost  e)
983| Ecost c e ⇒ Icost c e t (expr_ind2 P Q IE Iconst_int Iconst_float Ivar Ideref Iaddrof Iunop Ibinop Icast Icond Iandbool Iorbool Isizeof Ifield Icost e)
984].
985
986
987(* Correctness: we can't use a lock-step simulation result. The exec_step for Sswitch will be matched
988   by a non-constant number of evaluations in the converted program. More precisely,
989   [seq_of_labeled_statement (select_switch sz n sl)] will be matched by all the steps
990   necessary to execute all the "if-then-elses" corresponding to cases /before/ [n]. *)
991   
992(* A version of simplify_switch hiding the ugly projs *)
993definition fresh_for_expression ≝
994λe,u. fresh_for_univ SymbolTag (max_of_expr e) u.
995
996definition fresh_for_statement ≝
997λs,u. fresh_for_univ SymbolTag (max_of_statement s) u.
998
999(* needed during mutual induction ... *)
1000definition fresh_for_labeled_statements ≝
1001λls,u. fresh_for_univ ? (max_of_ls ls) u.
1002   
1003definition fresh_for_function ≝
1004λf,u. fresh_for_univ SymbolTag (max_id_of_function f) u.
1005
1006(* misc properties of the max function on positives. *)
1007
1008lemma max_one_neutral : ∀v. max v one = v.
1009* // qed.
1010
1011lemma max_id_one_neutral : ∀v. max_id v (an_identifier ? one) = v.
1012* #p whd in ⊢ (??%?); >max_one_neutral // qed.
1013
1014lemma max_id_commutative : ∀v1, v2. max_id v1 v2 = max_id v2 v1.
1015* #p1 * #p2 whd in match (max_id ??) in ⊢ (??%%);
1016>commutative_max // qed.
1017
1018lemma transitive_le : transitive ? le. // qed.
1019
1020lemma le_S_weaken : ∀a,b. le (succ a) b → le a b.
1021#a #b /2/ qed.
1022
1023(* cycle of length 1 *)
1024lemma le_S_contradiction_1 : ∀a. le (succ a) a → False.
1025* /2 by absurd/ qed.
1026
1027(* cycle of length 2 *)
1028lemma le_S_contradiction_2 : ∀a,b. le (succ a) b → le (succ b) a → False.
1029#a #b #H1 #H2 lapply (le_to_le_to_eq … (le_S_weaken ?? H1) (le_S_weaken ?? H2))
1030#Heq @(le_S_contradiction_1 a) destruct // qed.
1031
1032(* cycle of length 3 *)
1033lemma le_S_contradiction_3 : ∀a,b,c. le (succ a) b → le (succ b) c → le (succ c) a → False.
1034#a #b #c #H1 #H2 #H3 lapply (transitive_le … H1 (le_S_weaken ?? H2)) #H4
1035@(le_S_contradiction_2 … H3 H4)
1036qed.
1037
1038lemma reflexive_leb : ∀a. leb a a = true.
1039#a @(le_to_leb_true a a) // qed.
1040
1041(* This should be somewhere else. *)
1042lemma associative_max : associative ? max.
1043#a #b #c
1044whd in ⊢ (??%%); whd in match (max a b); whd in match (max b c);
1045lapply (pos_compare_to_Prop a b)
1046cases (pos_compare a b) whd in ⊢ (% → ?); #Hab
1047[ 1: >(le_to_leb_true a b) normalize nodelta /2/
1048     lapply (pos_compare_to_Prop b c)
1049     cases (pos_compare b c) whd in ⊢ (% → ?); #Hbc
1050     [ 1: >(le_to_leb_true b c) normalize nodelta
1051          lapply (pos_compare_to_Prop a c)
1052          cases (pos_compare a c) whd in ⊢ (% → ?); #Hac
1053          [ 1: >(le_to_leb_true a c) /2/
1054          | 2: destruct cases (leb c c) //
1055          | 3: (* There is an obvious contradiction in the hypotheses. omega, I miss you *)
1056               @(False_ind … (le_S_contradiction_3 ??? Hab Hbc Hac))           
1057          ]
1058          @le_S_weaken //
1059     | 2: destruct
1060          cases (leb c c) normalize nodelta
1061          >(le_to_leb_true a c) /2/
1062     | 3: >(not_le_to_leb_false b c) normalize nodelta /2/
1063          >(le_to_leb_true a b) /2/
1064     ]
1065| 2: destruct (Hab) >reflexive_leb normalize nodelta
1066     lapply (pos_compare_to_Prop b c)
1067     cases (pos_compare b c) whd in ⊢ (% → ?); #Hbc
1068     [ 1: >(le_to_leb_true b c) normalize nodelta
1069          >(le_to_leb_true b c) normalize nodelta
1070          /2/
1071     | 2: destruct >reflexive_leb normalize nodelta
1072          >reflexive_leb //
1073     | 3: >(not_le_to_leb_false b c) normalize nodelta
1074          >reflexive_leb /2/ ]
1075| 3: >(not_le_to_leb_false a b) normalize nodelta /2/
1076     lapply (pos_compare_to_Prop b c)
1077     cases (pos_compare b c) whd in ⊢ (% → ?); #Hbc
1078     [ 1: >(le_to_leb_true b c) normalize nodelta /2/
1079     | 2: destruct >reflexive_leb normalize nodelta @refl
1080     | 3: >(not_le_to_leb_false b c) normalize nodelta
1081          >(not_le_to_leb_false a b) normalize nodelta
1082          >(not_le_to_leb_false a c) normalize nodelta
1083          lapply (transitive_le … Hbc (le_S_weaken … Hab))
1084          #Hca /2/
1085     ]
1086] qed.   
1087
1088lemma max_id_associative : ∀v1, v2, v3. max_id (max_id v1 v2) v3 = max_id v1 (max_id v2 v3).
1089* #a * #b * #c whd in match (max_id ??) in ⊢ (??%%); >associative_max //
1090qed.
1091(*
1092lemma max_of_expr_rewrite :
1093  ∀e,id. max_of_expr e id = max_id (max_of_expr e (an_identifier SymbolTag one)) id.
1094@(expr_ind2 … (λed,t. ∀id. max_of_expr (Expr ed t) id=max_id (max_of_expr (Expr ed t) (an_identifier SymbolTag one)) id))
1095[ 1: #ed #t // ]
1096[ 1: #sz #i | 2: #fl | 3: #var_id | 4: #e1 | 5: #e1 | 6: #op #e1 | 7: #op #e1 #e2 | 8: #cast_ty #e1
1097| 9: #cond #iftrue #iffalse | 10: #e1 #e2 | 11: #e1 #e2 | 12: #sizeofty | 13: #e1 #field | 14: #cost #e1 ]
1098#ty
1099[ 3: * #id_p whd in match (max_of_expr ??); cases var_id #var_p normalize nodelta
1100     whd in match (max_id ??) in ⊢ (???%);
1101     >max_one_neutral // ]
1102[ 1,2,11: * * //
1103| 3,4,5,7,13: #Hind #id whd in match (max_of_expr (Expr ??) ?) in ⊢ (??%%); @Hind
1104| 6,9,10: #Hind1 #Hind2 #id whd in match (max_of_expr (Expr ??) ?) in ⊢ (??%%);
1105     >(Hind1 (max_of_expr e2 (an_identifier SymbolTag one)))
1106     >max_id_associative
1107     >Hind1
1108     cases (max_of_expr e1 ?)
1109     #v1 <Hind2 @refl
1110| 8: #Hind1 #Hind2 #Hind3 #id whd in match (max_of_expr (Expr ??) ?) in ⊢ (??%%);
1111     >Hind1 in ⊢ (??%?); >Hind2 in ⊢ (??%?); >Hind3 in ⊢ (??%?);
1112     >Hind1 in ⊢ (???%); >Hind2 in ⊢ (???%);
1113     >max_id_associative >max_id_associative @refl
1114| 12: #Hind #id whd in match (max_of_expr (Expr ??) ?) in ⊢ (??%%);
1115      cases field #p normalize nodelta
1116      >Hind cases (max_of_expr e1 ?) #e'
1117      cases id #id'
1118      whd in match (max_id ??); normalize nodelta
1119      whd in match (max_id ??); >associative_max @refl
1120] qed.
1121*)
1122lemma fresh_max_split : ∀a,b,u. fresh_for_univ SymbolTag (max_id a b) u → fresh_for_univ ? a u ∧ fresh_for_univ ? b u.
1123* #a * #b * #u normalize
1124lapply (pos_compare_to_Prop a b)
1125cases (pos_compare a b) whd in ⊢ (% → ?); #Hab
1126[ 1: >(le_to_leb_true a b) try /2/ #Hbu @conj /2/
1127| 2: destruct >reflexive_leb /2/
1128| 3: >(not_le_to_leb_false a b) try /2/ #Hau @conj /2/
1129] qed.
1130
1131(* Auxilliary commutation lemma used in [substatement_fresh]. *)
1132
1133lemma foldl_max : ∀l,a,b.
1134  foldl ?? (λacc,elt.max_id (max_of_expr elt) acc) (max_id a b) l =
1135  max_id a (foldl ?? (λacc,elt.max_id (max_of_expr elt) acc) b l).
1136#l elim l
1137[ 1: * #a * #b whd in match (foldl ?????) in ⊢ (??%%); @refl
1138| 2: #hd #tl #Hind #a #b whd in match (foldl ?????) in ⊢ (??%%);
1139     <Hind <max_id_commutative >max_id_associative >(max_id_commutative b ?) @refl
1140] qed.
1141
1142(* -----------------------------------------------------------------------------
1143   Stuff on memory and environments extensions.
1144   Let us recap: the memory model of a function is in two layers. An environment
1145   (type [env]) maps identifiers to blocks, and a memory maps blocks
1146   switch_removal introduces new, fresh variables. What is to be noted is that
1147   switch_removal modifies both the contents of the "disjoint" part of memory, but
1148   also where the data is allocated. The first solution considered was to consider
1149   an extensional equivalence relation on values, saying that equivalent pointers
1150   point to equivalent values. This has to be a coinductive relation, in order to
1151   take into account cyclic data structures. Rather than using coinductive types,
1152   we use the compcert solution, using so-called memory embeddings.
1153   ---------------------------------------------------------------------------- *)
1154
1155(* ---------------- *)
1156(* auxillary lemmas *)
1157lemma zlt_succ : ∀a,b. Zltb a b = true → Zltb a (Zsucc b) = true.
1158#a #b #HA
1159lapply (Zltb_true_to_Zlt … HA) #HA_prop
1160@Zlt_to_Zltb_true /2/
1161qed.
1162
1163lemma zlt_succ_refl : ∀a. Zltb a (Zsucc a) = true.
1164#a @Zlt_to_Zltb_true /2/ qed.
1165(*
1166definition le_offset : offset → offset → bool.
1167  λx,y. Zleb (offv x) (offv y).
1168*)
1169lemma not_refl_absurd : ∀A:Type[0].∀x:A. x ≠ x → False. /2/. qed.
1170
1171lemma eqZb_reflexive : ∀x:Z. eqZb x x = true. #x /2/. qed.
1172
1173(* When equality on A is decidable, [mem A elt l] is too. *)
1174lemma mem_dec : ∀A:Type[0]. ∀eq:(∀a,b:A. a = b ∨ a ≠ b). ∀elt,l. mem A elt l ∨ ¬ (mem A elt l).
1175#A #dec #elt #l elim l
1176[ 1: normalize %2 /2/
1177| 2: #hd #tl #Hind
1178     elim (dec elt hd)
1179     [ 1: #Heq >Heq %1 /2/
1180     | 2: #Hneq cases Hind
1181        [ 1: #Hmem %1 /2/
1182        | 2: #Hnmem %2 normalize
1183              % #H cases H
1184              [ 1: lapply Hneq * #Hl #Eq @(Hl Eq)
1185              | 2: lapply Hnmem * #Hr #Hmem @(Hr Hmem) ]
1186] ] ]
1187qed.
1188
1189lemma block_eq_dec : ∀a,b:block. a = b ∨ a ≠ b.
1190#a #b @(eq_block_elim … a b) /2/ qed.
1191
1192lemma mem_not_mem_neq : ∀l,elt1,elt2. (mem block elt1 l) → ¬ (mem block elt2 l) → elt1 ≠ elt2.
1193#l #elt1 #elt2 elim l
1194[ 1: normalize #Habsurd @(False_ind … Habsurd)
1195| 2: #hd #tl #Hind normalize #Hl #Hr
1196   cases Hl
1197   [ 1: #Heq >Heq
1198        @(eq_block_elim … hd elt2)
1199        [ 1: #Heq >Heq /2 by not_to_not/
1200        | 2: #x @x ]
1201   | 2: #Hmem1 cases (mem_dec … block_eq_dec elt2 tl)
1202        [ 1: #Hmem2 % #Helt_eq cases Hr #H @H %2 @Hmem2
1203        | 2: #Hmem2 @Hind //
1204        ]
1205   ]
1206] qed.
1207
1208lemma neq_block_eq_block_false : ∀b1,b2:block. b1 ≠ b2 → eq_block b1 b2 = false.
1209#b1 #b2 * #Hb
1210@(eq_block_elim … b1 b2)
1211[ 1: #Habsurd @(False_ind … (Hb Habsurd))
1212| 2: // ] qed.
1213
1214(* Type of blocks in a particular region. *)
1215definition block_in : region → Type[0] ≝ λrg. Σb. (block_region b) = rg.
1216
1217(* An embedding is a function from blocks to (blocks+offset). *)
1218definition embedding ≝ block → option (block × offset).
1219
1220definition offset_plus : offset → offset → offset ≝
1221  λo1,o2. mk_offset (addition_n ? (offv o1) (offv o2)).
1222 
1223 
1224(* Prove that (zero n) is a neutral element for (addition_n n) *) 
1225
1226lemma add_with_carries_n_O : ∀n,bv. add_with_carries n bv (zero n) false = 〈bv,zero n〉.
1227#n #bv whd in match (add_with_carries ????); elim bv //
1228#n #hd #tl #Hind whd in match (fold_right2_i ????????);
1229>Hind normalize
1230cases n in tl;
1231[ 1: #tl cases hd normalize @refl
1232| 2: #n' #tl cases hd normalize @refl ]
1233qed.
1234
1235lemma addition_n_0 : ∀n,bv. addition_n n bv (zero n) = bv.
1236#n #bv whd in match (addition_n ???);
1237>add_with_carries_n_O //
1238qed.
1239
1240lemma offset_plus_0 : ∀o. offset_plus o (mk_offset (zero ?)) = o.
1241* #o
1242whd in match (offset_plus ??);
1243>addition_n_0 @refl
1244qed.
1245
1246
1247(* Translates a pointer through an embedding. *)
1248definition pointer_translation : ∀p:pointer. ∀E:embedding. option pointer ≝
1249λp,E.
1250match p with
1251[ mk_pointer pblock poff ⇒
1252   match E pblock with
1253   [ None ⇒ None ?
1254   | Some loc ⇒
1255    let 〈dest_block,dest_off〉 ≝ loc in
1256    let ptr ≝ (mk_pointer dest_block (offset_plus poff dest_off)) in
1257    Some ? ptr
1258   ]
1259].
1260
1261(* We parameterise the "equivalence" relation on values with an embedding. *)
1262(* Front-end values. *)
1263inductive value_eq (E : embedding) : val → val → Prop ≝
1264| undef_eq : ∀v.
1265  value_eq E Vundef v
1266| vint_eq : ∀sz,i.
1267  value_eq E (Vint sz i) (Vint sz i)
1268| vfloat_eq : ∀f.
1269  value_eq E (Vfloat f) (Vfloat f)
1270| vnull_eq :
1271  value_eq E Vnull Vnull
1272| vptr_eq : ∀p1,p2.
1273  pointer_translation p1 E = Some ? p2 →
1274  value_eq E (Vptr p1) (Vptr p2).
1275
1276(* [load_sim] states the fact that each successful load in [m1] is matched by a load in [m2] s.t.
1277 * the values are equivalent. *)
1278definition load_sim ≝
1279λ(E : embedding).λ(m1 : mem).λ(m2 : mem).
1280 ∀b1,off1,b2,off2,ty,v1.
1281  valid_block m1 b1 →  (* We need this because it is not provable from [load_value_of_type ty m1 b1 off1] when loading by-ref *)
1282  E b1 = Some ? 〈b2,off2〉 →
1283  load_value_of_type ty m1 b1 off1 = Some ? v1 →
1284  (∃v2. load_value_of_type ty m2 b2 (offset_plus off1 off2) = Some ? v2 ∧ value_eq E v1 v2).
1285
1286definition load_sim_ptr ≝
1287λ(E : embedding).λ(m1 : mem).λ(m2 : mem).
1288 ∀b1,off1,b2,off2,ty,v1.
1289  valid_pointer m1 (mk_pointer b1 off1) = true →  (* We need this because it is not provable from [load_value_of_type ty m1 b1 off1] when loading by-ref *)
1290  pointer_translation (mk_pointer b1 off1) E = Some ? (mk_pointer b2 off2) →
1291  load_value_of_type ty m1 b1 off1 = Some ? v1 →
1292  (∃v2. load_value_of_type ty m2 b2 off2 = Some ? v2 ∧ value_eq E v1 v2).
1293
1294(* Definition of a memory injection *)
1295record memory_inj (E : embedding) (m1 : mem) (m2 : mem) : Type[0] ≝
1296{ (* Load simulation *)
1297  mi_inj : load_sim_ptr E m1 m2;
1298  (* Invalid blocks are not mapped *)
1299  mi_freeblock : ∀b. ¬ (valid_block m1 b) → E b = None ?;
1300  (* Valid pointers are mapped to valid pointers*)
1301  mi_valid_pointers : ∀p,p'.
1302                       valid_pointer m1 p = true →
1303                       pointer_translation p E = Some ? p' →
1304                       valid_pointer m2 p' = true;
1305  (* Blocks in the codomain are valid *)
1306  (* mi_incl : ∀b,b',o'. E b = Some ? 〈b',o'〉 → valid_block m2 b'; *)
1307  (* Regions are preserved *)
1308  mi_region : ∀b,b',o'. E b = Some ? 〈b',o'〉 → block_region b = block_region b';
1309  (* Disjoint blocks are mapped to disjoint blocks. Note that our condition is stronger than compcert's.
1310   * This may cause some problems if we reuse this def for the translation from Clight to Cminor, where
1311   * all variables are allocated in the same block. *)
1312  mi_disjoint : ∀b1,b2,b1',b2',o1',o2'.
1313                b1 ≠ b2 →
1314                E b1 = Some ? 〈b1',o1'〉 →
1315                E b2 = Some ? 〈b2',o2'〉 →
1316                b1' ≠ b2'
1317}.
1318
1319(* Definition of a memory extension. /!\ Not equivalent to the compcert concept. /!\
1320 * A memory extension is a [memory_inj] with some particular blocks designated as
1321 * being writeable. *)
1322
1323alias id "meml" = "cic:/matita/basics/lists/list/mem.fix(0,2,1)".
1324
1325record memory_ext (E : embedding) (m1 : mem) (m2 : mem) : Type[0] ≝
1326{ me_inj : memory_inj E m1 m2;
1327  (* A list of blocks where we can write freely *)
1328  me_writeable : list block;
1329  (* These blocks are valid *)
1330  me_writeable_valid : ∀b. meml ? b me_writeable → valid_block m2 b;
1331  (* And pointers to m1 are oblivious to these blocks *)
1332  me_writeable_ok : ∀p,p'.
1333                     valid_pointer m1 p = true →
1334                     pointer_translation p E = Some ? p' →
1335                     ¬ (meml ? (pblock p') me_writeable)
1336}.
1337
1338(* ---------------------------------------------------------------------------- *)
1339(* End of the definitions on memory injections. Now, on to proving some lemmas. *)
1340
1341(* A particular inversion. *)
1342lemma value_eq_ptr_inversion :
1343  ∀E,p1,v. value_eq E (Vptr p1) v → ∃p2. v = Vptr p2 ∧ pointer_translation p1 E = Some ? p2.
1344#E #p1 #v #Heq inversion Heq
1345[ 1: #v #Habsurd destruct (Habsurd)
1346| 2: #sz #i #Habsurd destruct (Habsurd)
1347| 3: #f #Habsurd destruct (Habsurd)
1348| 4:  #Habsurd destruct (Habsurd)
1349| 5: #p1' #p2 #Heq #Heqv #Heqv2 #_ destruct
1350     %{p2} @conj try @refl try assumption
1351] qed.
1352
1353(* A cleaner version of inversion for [value_eq] *)
1354lemma value_eq_inversion :
1355  ∀E,v1,v2. ∀P : val → val → Prop. value_eq E v1 v2 →
1356  (∀v. P Vundef v) →
1357  (∀sz,i. P (Vint sz i) (Vint sz i)) →
1358  (∀f. P (Vfloat f) (Vfloat f)) →
1359  (P Vnull Vnull) →
1360  (∀p1,p2. pointer_translation p1 E = Some ? p2 → P (Vptr p1) (Vptr p2)) →
1361  P v1 v2.
1362#E #v1 #v2 #P #Heq #H1 #H2 #H3 #H4 #H5
1363inversion Heq
1364[ 1: #v #Hv1 #Hv2 #_ destruct @H1
1365| 2: #sz #i #Hv1 #Hv2 #_ destruct @H2
1366| 3: #f #Hv1 #Hv2 #_ destruct @H3
1367| 4: #Hv1 #Hv2 #_ destruct @H4
1368| 5: #p1 #p2 #Hembed #Hv1 #Hv2 #_ destruct @H5 // ] qed.
1369 
1370(* If we succeed to load something by value from a 〈b,off〉 location,
1371   [b] is a valid block. *)
1372lemma load_by_value_success_valid_block_aux :
1373  ∀ty,m,b,off,v.
1374    access_mode ty = By_value (typ_of_type ty) →
1375    load_value_of_type ty m b off = Some ? v →
1376    Zltb (block_id b) (nextblock m) = true.
1377#ty #m * #brg #bid #off #v
1378cases ty
1379[ 1: | 2: #sz #sg | 3: #fsz | 4: #ptr_ty | 5: #array_ty #array_sz | 6: #domain #codomain
1380| 7: #structname #fieldspec | 8: #unionname #fieldspec | 9: #id ]
1381whd in match (load_value_of_type ????);
1382[ 1,7,8: #_ #Habsurd destruct (Habsurd) ]
1383#Hmode
1384[ 1,2,3,6: [ 1: elim sz | 2: elim fsz ]
1385     normalize in match (typesize ?);
1386     whd in match (loadn ???);
1387     whd in match (beloadv ??);
1388     cases (Zltb bid (nextblock m)) normalize nodelta
1389     try // #Habsurd destruct (Habsurd)
1390| *: normalize in Hmode; destruct (Hmode)
1391] qed.
1392
1393(* If we succeed in loading some data from a location, then this loc is a valid pointer. *)
1394lemma load_by_value_success_valid_ptr_aux :
1395  ∀ty,m,b,off,v.
1396    access_mode ty = By_value (typ_of_type ty) →
1397    load_value_of_type ty m b off = Some ? v →
1398    Zltb (block_id b) (nextblock m) = true ∧
1399    Zleb (low_bound m b) (Z_of_unsigned_bitvector ? (offv off)) = true ∧
1400    Zltb (Z_of_unsigned_bitvector ? (offv off)) (high_bound m b) = true.
1401#ty #m * #brg #bid #off #v
1402cases ty
1403[ 1: | 2: #sz #sg | 3: #fsz | 4: #ptr_ty | 5: #array_ty #array_sz | 6: #domain #codomain
1404| 7: #structname #fieldspec | 8: #unionname #fieldspec | 9: #id ]
1405whd in match (load_value_of_type ????);
1406[ 1,7,8: #_ #Habsurd destruct (Habsurd) ]
1407#Hmode
1408[ 1,2,3,6: [ 1: elim sz | 2: elim fsz ]
1409     normalize in match (typesize ?);
1410     whd in match (loadn ???);
1411     whd in match (beloadv ??);
1412     cases (Zltb bid (nextblock m)) normalize nodelta
1413     cases (Zleb (low (blocks m (mk_block brg bid)))
1414                  (Z_of_unsigned_bitvector offset_size (offv off)))
1415     cases (Zltb (Z_of_unsigned_bitvector offset_size (offv off)) (high (blocks m (mk_block brg bid))))
1416     normalize nodelta
1417     #Heq destruct (Heq)
1418     try /3 by conj, refl/
1419| *: normalize in Hmode; destruct (Hmode)
1420] qed.
1421
1422
1423lemma valid_block_from_bool : ∀b,m. Zltb (block_id b) (nextblock m) = true → valid_block m b.
1424* #rg #id #m normalize
1425elim id /2/ qed.
1426
1427lemma valid_block_to_bool : ∀b,m. valid_block m b → Zltb (block_id b) (nextblock m) = true.
1428* #rg #id #m normalize
1429elim id /2/ qed.
1430
1431lemma load_by_value_success_valid_block :
1432  ∀ty,m,b,off,v.
1433    access_mode ty = By_value (typ_of_type ty) →
1434    load_value_of_type ty m b off = Some ? v →
1435    valid_block m b.
1436#ty #m #b #off #v #Haccess_mode #Hload
1437@valid_block_from_bool
1438elim (load_by_value_success_valid_ptr_aux ty m b off v Haccess_mode Hload) * //
1439qed.
1440
1441lemma load_by_value_success_valid_pointer :
1442  ∀ty,m,b,off,v.
1443    access_mode ty = By_value (typ_of_type ty) →
1444    load_value_of_type ty m b off = Some ? v →
1445    valid_pointer m (mk_pointer b off).
1446#ty #m #b #off #v #Haccess_mode #Hload normalize
1447elim (load_by_value_success_valid_ptr_aux ty m b off v Haccess_mode Hload)
1448* #H1 #H2 #H3 >H1 >H2 normalize nodelta
1449>Zle_to_Zleb_true try //
1450lapply (Zlt_to_Zle … (Zltb_true_to_Zlt … H3)) /2/
1451qed.
1452
1453
1454(* Making explicit the contents of memory_inj for load_value_of_type *)
1455lemma load_value_of_type_inj : ∀E,m1,m2,b1,off1,v1,b2,off2,ty.
1456    memory_inj E m1 m2 →
1457    value_eq E (Vptr (mk_pointer b1 off1)) (Vptr (mk_pointer b2 off2)) →
1458    load_value_of_type ty m1 b1 off1 = Some ? v1 →
1459    ∃v2. load_value_of_type ty m2 b2 off2 = Some ? v2 ∧ value_eq E v1 v2.
1460#E #m1 #m2 #b1 #off1 #v1 #b2 #off2 #ty #Hinj #Hvalue_eq
1461lapply (value_eq_ptr_inversion … Hvalue_eq) * #p2 * #Hp2_eq #Hembed destruct
1462lapply (refl ? (access_mode ty))
1463cases ty
1464[ 1: | 2: #sz #sg | 3: #fsz | 4: #ptr_ty | 5: #array_ty #array_sz | 6: #domain #codomain
1465| 7: #structname #fieldspec | 8: #unionname #fieldspec | 9: #id ]
1466normalize in ⊢ ((???%) → ?); #Hmode #Hyp
1467[ 1,7,8: normalize in Hyp; destruct (Hyp)
1468| 5,6: normalize in Hyp ⊢ %; destruct (Hyp) /3 by ex_intro, conj, vptr_eq/ ]
1469lapply (load_by_value_success_valid_pointer … Hmode … Hyp) #Hvalid_pointer
1470lapply (mi_inj … Hinj b1 off1 b2 off2 … Hvalid_pointer Hembed Hyp) #H @H
1471qed.     
1472
1473
1474(* -------------------------------------- *)
1475(* Lemmas pertaining to memory allocation *)
1476
1477(* A valid block stays valid after an alloc. *)
1478lemma alloc_valid_block_conservation :
1479  ∀m,m',z1,z2,r,new_block.
1480  alloc m z1 z2 r = 〈m', new_block〉 →
1481  ∀b. valid_block m b → valid_block m' b.
1482#m #m' #z1 #z2 #r * #b' #Hregion_eq
1483elim m #contents #nextblock #Hcorrect whd in match (alloc ????);
1484#Halloc destruct (Halloc)
1485#b whd in match (valid_block ??) in ⊢ (% → %); /2/
1486qed.
1487
1488(* Allocating a new zone produces a valid block. *)
1489lemma alloc_valid_new_block :
1490  ∀m,m',z1,z2,r,new_block.
1491  alloc m z1 z2 r = 〈m', new_block〉 →
1492  valid_block m' new_block.
1493* #contents #nextblock #Hcorrect #m' #z1 #z2 #r * #new_block #Hregion_eq
1494whd in match (alloc ????); whd in match (valid_block ??);
1495#Halloc destruct (Halloc) /2/
1496qed.
1497
1498(* All data in a valid block is unchanged after an alloc. *)
1499lemma alloc_beloadv_conservation :
1500  ∀m,m',block,offset,z1,z2,r,new_block.
1501    valid_block m block →
1502    alloc m z1 z2 r = 〈m', new_block〉 →
1503    beloadv m (mk_pointer block offset) = beloadv m' (mk_pointer block offset).
1504* #contents #next #Hcorrect #m' #block #offset #z1 #z2 #r #new_block #Hvalid #Halloc
1505whd in Halloc:(??%?); destruct (Halloc)
1506whd in match (beloadv ??) in ⊢ (??%%);
1507lapply (valid_block_to_bool … Hvalid) #Hlt
1508>Hlt >(zlt_succ … Hlt)
1509normalize nodelta whd in match (update_block ?????); whd in match (eq_block ??);
1510cut (eqZb (block_id block) next = false)
1511[ lapply (Zltb_true_to_Zlt … Hlt) #Hlt' @eqZb_false /2/ ] #Hneq
1512>Hneq cases (eq_region ??) normalize nodelta  @refl
1513qed.
1514
1515(* Lift [alloc_beloadv_conservation] to loadn *)
1516lemma alloc_loadn_conservation :
1517  ∀m,m',z1,z2,r,new_block.
1518    alloc m z1 z2 r = 〈m', new_block〉 →
1519    ∀n. ∀block,offset.
1520    valid_block m block →
1521    loadn m (mk_pointer block offset) n = loadn m' (mk_pointer block offset) n.
1522#m #m' #z1 #z2 #r #new_block #Halloc #n
1523elim n try //
1524#n' #Hind #block #offset #Hvalid_block
1525whd in ⊢ (??%%);
1526>(alloc_beloadv_conservation … Hvalid_block Halloc)
1527cases (beloadv m' (mk_pointer block offset)) //
1528#bev normalize nodelta
1529whd in match (shift_pointer ???); >Hind try //
1530qed.
1531
1532(* Memory allocation preserves [memory_inj] *)
1533lemma alloc_memory_inj :
1534  ∀E:embedding.∀m1,m2,m2',z1,z2,r,new_block. ∀H:memory_inj E m1 m2.
1535  alloc m2 z1 z2 r = 〈m2', new_block〉 →
1536  memory_inj E m1 m2'.
1537#E #m1 #m2 #m2' #z1 #z2 #r * #new_block #Hregion #Hmemory_inj #Halloc
1538%
1539[ 1:
1540  whd
1541  #b1 #off1 #b2 #off2 #ty #v1 #Hvalid #Hembed #Hload
1542  elim (mi_inj E m1 m2 Hmemory_inj b1 off1 b2 off2 … ty v1 Hvalid Hembed Hload)
1543  #v2 * #Hload_eq #Hvalue_eq %{v2} @conj try //
1544  lapply (refl ? (access_mode ty))
1545  cases ty in Hload_eq;
1546  [ 1: | 2: #sz #sg | 3: #fsz | 4: #ptr_ty | 5: #array_ty #array_sz | 6: #domain #codomain
1547  | 7: #structname #fieldspec | 8: #unionname #fieldspec | 9: #id ]
1548  #Hload normalize in ⊢ ((???%) → ?); #Haccess
1549  [ 1,7,8: normalize in Hload; destruct (Hload)
1550  | 2,3,4,9: whd in match (load_value_of_type ????);
1551     whd in match (load_value_of_type ????);
1552     lapply (load_by_value_success_valid_block … Haccess Hload)
1553     #Hvalid_block
1554     whd in match (load_value_of_type ????) in Hload;
1555     <(alloc_loadn_conservation … Halloc … Hvalid_block)
1556     @Hload
1557  | 5,6: whd in match (load_value_of_type ????) in Hload ⊢ %; @Hload ]
1558| 2: @(mi_freeblock … Hmemory_inj)
1559| 3: #p #p' #Hvalid #Hptr_trans lapply (mi_valid_pointers … Hmemory_inj p p' Hvalid Hptr_trans)
1560     elim m2 in Halloc; #contentmap #nextblock #Hnextblock
1561     elim p' * #br' #bid' #o' #Halloc whd in Halloc:(??%?) ⊢ ?; destruct (Halloc)
1562     whd in match (valid_pointer ??) in ⊢ (% → %);
1563     @Zltb_elim_Type0
1564     [ 2: normalize #_ #Habsurd destruct (Habsurd) ]
1565     #Hbid' cut (Zltb bid' (Zsucc nextblock) = true) [ lapply (Zlt_to_Zltb_true … Hbid') @zlt_succ ]
1566     #Hbid_succ >Hbid_succ whd in match (low_bound ??) in ⊢ (% → %);
1567     whd in match (high_bound ??) in ⊢ (% → %);
1568     whd in match (update_block ?????);
1569     whd in match (eq_block ??);
1570     cut (eqZb bid' nextblock = false) [ 1: @eqZb_false /2 by not_to_not/ ]
1571     #Hbid_neq >Hbid_neq
1572     cases (eq_region br' r) normalize #H @H
1573| 4: @(mi_region … Hmemory_inj)
1574| 5: @(mi_disjoint … Hmemory_inj)
1575] qed.
1576
1577(* Memory allocation induces a memory extension. *)
1578lemma alloc_memory_ext :
1579  ∀E:embedding.∀m1,m2,m2',z1,z2,r,new_block. ∀H:memory_inj E m1 m2.
1580  alloc m2 z1 z2 r = 〈m2', new_block〉 →
1581  memory_ext E m1 m2'.
1582#E #m1 #m2 #m2' #z1 #z2 #r * #new_block #Hblock_region_eq #Hmemory_inj #Halloc
1583lapply (alloc_memory_inj … Hmemory_inj Halloc)
1584#Hinj' %
1585[ 1: @Hinj'
1586| 2: @[new_block]
1587| 3: #b normalize in ⊢ (%→ ?); * [ 2: #H @(False_ind … H) ]
1588      #Heq destruct (Heq) whd elim m2 in Halloc;
1589      #Hcontents #nextblock #Hnextblock
1590      whd in ⊢ ((??%?) → ?); #Heq destruct (Heq)
1591      /2/
1592| 4: * #b #o * #b' #o' #Hvalid_ptr #Hembed %
1593     normalize in ⊢ (% → ?); * [ 2: #H @H ]
1594     #Heq destruct (Heq)
1595     lapply (mi_valid_pointers … Hmemory_inj … Hvalid_ptr Hembed)
1596     whd in ⊢ (% → ?);
1597     (* contradiction because ¬ (valid_block m2 new_block)  *)
1598     elim m2 in Halloc;
1599     #contents_m2 #nextblock_m2 #Hnextblock_m2
1600     whd in ⊢ ((??%?) → ?);
1601     #Heq_alloc destruct (Heq_alloc)
1602     normalize
1603     lapply (irreflexive_Zlt nextblock_m2)
1604     @Zltb_elim_Type0
1605     [ #H * #Habsurd @(False_ind … (Habsurd H)) ] #_ #_ normalize #Habsurd destruct (Habsurd)
1606] qed.
1607
1608lemma bestorev_beloadv_conservation :
1609  ∀mA,mB,wb,wo,v.
1610    bestorev mA (mk_pointer wb wo) v = Some ? mB →
1611    ∀rb,ro. eq_block wb rb = false →
1612    beloadv mA (mk_pointer rb ro) = beloadv mB (mk_pointer rb ro).
1613#mA #mB #wb #wo #v #Hstore #rb #ro #Hblock_neq
1614whd in ⊢ (??%%);
1615elim mB in Hstore; #contentsB #nextblockB #HnextblockB
1616normalize in ⊢ (% → ?);
1617cases (Zltb (block_id wb) (nextblock mA)) normalize nodelta
1618[ 2: #Habsurd destruct (Habsurd) ]
1619cases (if Zleb (low (blocks mA wb)) (Z_of_unsigned_bitvector 16 (offv wo))
1620       then Zltb (Z_of_unsigned_bitvector 16 (offv wo)) (high (blocks mA wb)) 
1621       else false) normalize nodelta
1622[ 2: #Habsurd destruct (Habsurd) ]
1623#Heq destruct (Heq) elim rb in Hblock_neq; #rr #rid elim wb #wr #wid
1624cases rr cases wr normalize try //
1625@(eqZb_elim … rid wid)
1626[ 1,3: #Heq destruct (Heq) >(eqZb_reflexive wid) #Habsurd destruct (Habsurd) ]
1627try //
1628qed.
1629
1630(* lift [bestorev_beloadv_conservation to [loadn] *)
1631lemma bestorev_loadn_conservation :
1632  ∀mA,mB,n,wb,wo,v.
1633    bestorev mA (mk_pointer wb wo) v = Some ? mB →
1634    ∀rb,ro. eq_block wb rb = false →
1635    loadn mA (mk_pointer rb ro) n = loadn mB (mk_pointer rb ro) n.
1636#mA #mB #n
1637elim n
1638[ 1: #wb #wo #v #Hstore #rb #ro #Hblock_neq normalize @refl
1639| 2: #n' #Hind #wb #wo #v #Hstore #rb #ro #Hneq
1640     whd in ⊢ (??%%);
1641     >(bestorev_beloadv_conservation … Hstore … Hneq)
1642     >(Hind … Hstore … Hneq) @refl
1643] qed.
1644
1645(* lift [bestorev_loadn_conservation] to [load_value_of_type] *)
1646lemma bestorev_load_value_of_type_conservation :
1647  ∀mA,mB,wb,wo,v.
1648    bestorev mA (mk_pointer wb wo) v = Some ? mB →
1649    ∀rb,ro. eq_block wb rb = false →
1650    ∀ty.load_value_of_type ty mA rb ro = load_value_of_type ty mB rb ro.
1651#mA #mB #wb #wo #v #Hstore #rb #ro #Hneq #ty
1652cases ty
1653[ 1: | 2: #sz #sg | 3: #fsz | 4: #ptr_ty | 5: #array_ty #array_sz | 6: #domain #codomain
1654| 7: #structname #fieldspec | 8: #unionname #fieldspec | 9: #id ] try //
1655[ 1: elim sz | 2: elim fsz | 3: | 4: ]
1656whd in ⊢ (??%%);
1657>(bestorev_loadn_conservation … Hstore … Hneq) @refl
1658qed.
1659
1660(* Writing in the "extended" part of a memory preserves the underlying injection *)
1661lemma bestorev_memory_ext_to_load_sim :
1662  ∀E,mA,mB,mC.
1663  ∀Hext:memory_ext E mA mB.
1664  ∀wb,wo,v. meml ? wb (me_writeable … Hext) →
1665  bestorev mB (mk_pointer wb wo) v = Some ? mC →
1666  load_sim_ptr E mA mC.
1667#E #mA #mB #mC #Hext #wb #wo #v #Hwb #Hstore whd
1668#b1 #off1 #b2 #off2 #ty #v1 #Hvalid #Hembed #Hload
1669(* Show that (wb ≠ b2) by showing b2 ∉ (me_writeable ...) *)
1670lapply (me_writeable_ok … Hext (mk_pointer b1 off1) (mk_pointer b2 off2) Hvalid Hembed) #Hb2
1671lapply (mem_not_mem_neq … Hwb Hb2) #Hwb_neq_b2
1672cut ((eq_block wb b2) = false) [ @neq_block_eq_block_false @Hwb_neq_b2 ] #Heq_block_false
1673<(bestorev_load_value_of_type_conservation … Hstore … Heq_block_false)
1674@(mi_inj … (me_inj … Hext) … Hvalid  … Hembed …  Hload)
1675qed.
1676
1677(* Writing in the "extended" part of a memory preserves the whole memory injection *)
1678lemma bestorev_memory_ext_to_memory_inj :
1679  ∀E,mA,mB,mC.
1680  ∀Hext:memory_ext E mA mB.
1681  ∀wb,wo,v. meml ? wb (me_writeable … Hext) →
1682  bestorev mB (mk_pointer wb wo) v = Some ? mC →
1683  memory_inj E mA mC.
1684#E #mA * #contentsB #nextblockB #HnextblockB #mC
1685#Hext #wb #wo #v #Hwb #Hstore
1686%
1687[ 1: @(bestorev_memory_ext_to_load_sim … Hext … Hwb Hstore) ]
1688elim Hext in Hwb; * #Hinj #Hvalid #Hcodomain #Hregion #Hdisjoint #writeable #Hwriteable_valid #Hwriteable_ok
1689#Hmem
1690[ 1: @Hvalid | 3: @Hregion | 4: @Hdisjoint ] -Hvalid -Hregion -Hdisjoint
1691whd in Hstore:(??%?); lapply (Hwriteable_valid … Hmem)
1692normalize in ⊢ (% → ?); #Hlt_wb
1693#p #p' #HvalidA #Hembed lapply (Hcodomain … HvalidA Hembed) -Hcodomain
1694normalize in match (valid_pointer ??) in ⊢ (% → %);
1695>(Zlt_to_Zltb_true … Hlt_wb) in Hstore; normalize nodelta
1696cases (Zleb (low (contentsB wb)) (Z_of_unsigned_bitvector offset_size (offv wo))
1697       ∧Zltb (Z_of_unsigned_bitvector offset_size (offv wo)) (high (contentsB wb)))
1698normalize nodelta
1699[ 2: #Habsurd destruct (Habsurd) ]
1700#Heq destruct (Heq)
1701cases (Zltb (block_id (pblock p')) nextblockB) normalize nodelta
1702[ 2: // ]
1703whd in match (update_block ?????);
1704cut (eq_block (pblock p') wb = false)
1705[ 2: #Heq >Heq normalize nodelta #H @H ]
1706@neq_block_eq_block_false @sym_neq
1707@(mem_not_mem_neq writeable … Hmem)
1708@(Hwriteable_ok … HvalidA Hembed)
1709qed.
1710
1711(* It even preserves memory extensions, with the same writeable blocks.  *)
1712lemma bestorev_memory_ext_to_memory_ext :
1713  ∀E,mA,mB.
1714  ∀Hext:memory_ext E mA mB.
1715  ∀wb,wo,v. meml ? wb (me_writeable … Hext) →
1716  ∀mC.bestorev mB (mk_pointer wb wo) v = Some ? mC →
1717  ΣExt:memory_ext E mA mC.(me_writeable … Hext = me_writeable … Ext).
1718#E #mA #mB #Hext #wb #wo #v #Hmem #mC #Hstore
1719%{(mk_memory_ext …
1720      (bestorev_memory_ext_to_memory_inj … Hext … Hmem … Hstore)
1721      (me_writeable … Hext)
1722      ?
1723      (me_writeable_ok … Hext)
1724 )} try @refl
1725#b #Hmemb
1726lapply (me_writeable_valid … Hext b Hmemb)
1727lapply (me_writeable_valid … Hext wb Hmem)
1728elim mB in Hstore; #contentsB #nextblockB #HnextblockB #Hstore #Hwb_valid #Hb_valid
1729lapply Hstore normalize in Hwb_valid Hb_valid ⊢ (% → ?);
1730>(Zlt_to_Zltb_true … Hwb_valid) normalize nodelta
1731cases (if Zleb (low (contentsB wb)) (Z_of_unsigned_bitvector 16 (offv wo))
1732       then Zltb (Z_of_unsigned_bitvector 16 (offv wo)) (high (contentsB wb)) 
1733       else false)
1734normalize [ 2: #Habsurd destruct (Habsurd) ]
1735#Heq destruct (Heq) @Hb_valid
1736qed.
1737
1738(* Lift [bestorev_memory_ext_to_memory_ext] to storen *)
1739lemma storen_memory_ext_to_memory_ext :
1740  ∀E,mA,l,mB,mC.
1741  ∀Hext:memory_ext E mA mB.
1742  ∀wb,wo. meml ? wb (me_writeable … Hext) →
1743  storen mB (mk_pointer wb wo) l = Some ? mC →
1744  memory_ext E mA mC.
1745#E #mA #l elim l
1746[ 1: #mB #mC #Hext #wb #wo #Hmem normalize in ⊢ (% → ?); #Heq destruct (Heq)
1747     @Hext
1748| 2: #hd #tl #Hind #mB #mC #Hext #wb #wo #Hmem
1749     whd in ⊢ ((??%?) → ?);
1750     lapply (bestorev_memory_ext_to_memory_ext … Hext … wb wo hd Hmem)
1751     cases (bestorev mB (mk_pointer wb wo) hd)
1752     normalize nodelta
1753     [ 1: #H #Habsurd destruct (Habsurd) ]
1754     #mD #H lapply (H mD (refl ??)) * #HextD #Heq #Hstore
1755     @(Hind … HextD … Hstore)
1756     <Heq @Hmem
1757] qed.     
1758
1759(* Lift [storen_memory_ext_to_memory_ext] to store_value_of_type *)
1760lemma store_value_of_type_memory_ext_to_memory_ext :
1761  ∀E,mA,mB,mC.
1762  ∀Hext:memory_ext E mA mB.
1763  ∀wb,wo. meml ? wb (me_writeable … Hext) →
1764  ∀ty,v.store_value_of_type ty mB wb wo v = Some ? mC →
1765  memory_ext E mA mC.
1766#E #mA #mB #mC #Hext #wb #wo #Hmem #ty #v
1767cases ty
1768[ 1: | 2: #sz #sg | 3: #fsz | 4: #ptr_ty | 5: #array_ty #array_sz | 6: #domain #codomain
1769| 7: #structname #fieldspec | 8: #unionname #fieldspec | 9: #id ]
1770whd in ⊢ ((??%?) → ?);
1771[ 1,5,6,7,8: #Habsurd destruct (Habsurd) ]
1772#Hstore
1773@(storen_memory_ext_to_memory_ext … Hext … Hmem … Hstore)
1774qed.
1775
1776(* End of the memory injection-related stuff. *)
1777(* ------------------------------------------ *)
1778
1779(* Lookup functions in list environments (used to type local variables in functions) *)     
1780let rec mem_assoc_env (i : ident) (l : list (ident×type)) on l : bool ≝
1781match l with
1782[ nil ⇒ false
1783| cons hd tl ⇒
1784  let 〈id, ty〉 ≝ hd in
1785  match identifier_eq SymbolTag i id with
1786  [ inl Hid_eq ⇒ true
1787  | inr Hid_neq ⇒ mem_assoc_env i tl 
1788  ]
1789].
1790
1791let rec assoc_env (i : ident) (l : list (ident×type)) on l : option type ≝
1792match l with
1793[ nil ⇒ None ?
1794| cons hd tl ⇒
1795  let 〈id, ty〉 ≝ hd in
1796  match identifier_eq SymbolTag i id with
1797  [ inl Hid_eq ⇒ Some ? ty
1798  | inr Hid_neq ⇒ assoc_env i tl 
1799  ]
1800].
1801
1802(* [disjoint_extension e1 m1 e2 m2 types ext] states that [e2] is an extension
1803   of the environment [e1] s.t. the new binders are in [new], and such that those
1804   new binders are "writeable" in the memory extension [Hext] *)
1805definition disjoint_extension ≝
1806λ(e1 : env). λ(m1 : mem). λ(e2 : env). λ(m2 : mem).
1807λ(new : list (ident × type)). λ(E:embedding). λ(Hext: memory_ext E m1 m2).
1808  ∀id. match mem_assoc_env id new with
1809       [ true ⇒
1810           ∃b. lookup ?? e2 id = Some ? b
1811            ∧ meml ? b (me_writeable … Hext)
1812            ∧ lookup ?? e1 id = None ?
1813       | false ⇒
1814         match lookup ?? e1 id with
1815         [ None ⇒ lookup ?? e2 id = None ?
1816         | Some b1 ⇒
1817           match lookup ?? e2 id with
1818           [ None ⇒ False
1819           | Some b2 ⇒
1820             valid_block m1 b1 ∧
1821             value_eq E (Vptr (mk_pointer b1 zero_offset)) (Vptr (mk_pointer b2 zero_offset))
1822           ]
1823         ]
1824       ].
1825
1826(* In proofs, [disjoint_extension] is not enough. When a variable lookup arises, if
1827 * the variable is not in a local environment, then we search into the global one.
1828 * A proper "extension" of a local environment should be such that the extension
1829 * does not collide with a given global env.
1830 * To see the details of why we need that, see [exec_lvalue'], Evar id case.
1831 *)
1832definition ext_fresh_for_genv ≝
1833λ(ext : list (ident × type)). λ(ge : genv).
1834  ∀id. mem_assoc_env id ext = true → find_symbol … ge id = None ?.
1835
1836(* Any environment is a "disjoint" extension of itself with nothing. *)
1837(*
1838lemma disjoint_extension_nil : ∀e,m,types. disjoint_extension e m e m types [].
1839#e #m #ty #id
1840normalize in match (mem_assoc_env id []); normalize nodelta
1841cases (lookup ?? e id) try //
1842#b normalize nodelta
1843% #ty cases (load_value_of_type ????)
1844[ 1: %2 /2/ | 2: #v %1 %{v} %{v} @conj //
1845cases (assoc_env id ty) //
1846qed. *)
1847
1848
1849(* "generic" simulation relation on [res ?] *)
1850definition res_sim ≝
1851  λ(A : Type[0]).
1852  λ(eq : A → A → Prop).
1853  λ(r1, r2 : res A).
1854  ∀a1. r1 = OK ? a1 → ∃a2. r2 = OK ? a2 ∧ eq a1 a2.
1855
1856(* Specialisation of [res_sim] to match [exec_expr] *)
1857definition exec_expr_sim ≝ λE.
1858  res_sim (val × trace) (λr1,r2. value_eq E (\fst r1) (\fst r2) ∧ (\snd r1 = \snd r2)).
1859
1860(* Specialisation of [res_sim] to match [exec_lvalue] *)
1861definition exec_lvalue_sim ≝ λE.
1862  res_sim (block × offset × trace)
1863    (λr1,r2.
1864      let 〈b1,o1,tr1〉 ≝ r1 in
1865      let 〈b2,o2,tr2〉 ≝ r2 in
1866      value_eq E (Vptr (mk_pointer b1 o1)) (Vptr (mk_pointer b2 o2)) ∧ tr1 = tr2).
1867
1868lemma load_value_of_type_dec : ∀ty, m, b, o. load_value_of_type ty m b o = None ? ∨ ∃r. load_value_of_type ty m b o = Some ? r.
1869#ty #m #b #o cases (load_value_of_type ty m b o)
1870[ 1: %1 // | 2: #v %2 /2 by ex_intro/ ] qed.
1871
1872(*
1873lemma switch_removal_alloc_extension : ∀f, f', vars, env, env', m, m'.
1874   env = \fst (exec_alloc_variables empty_env m ((fn_params f) @ (fn_vars f))) →
1875   〈f',vars〉 = function_switch_removal f →
1876   env' = \fst (exec_alloc_variables empty_env m' ((fn_params f) @ vars @ (fn_vars f))) →
1877   environment_extension env env' vars.
1878
1879#f #f'
1880cut (∀l:list (ident × type). [ ] @ l = l) [ // ] #nil_append
1881cases (fn_params f) cases (fn_vars f)
1882[ 1: #vars >append_nil >append_nil >nil_append elim vars   
1883   [ 1: #env #env' #m #m' normalize in ⊢ (% → ? → % → ?); #Henv1 #_ #Henv2 destruct //
1884   | 2: #hd #tl #Hind #env #env' #m #m' #Henv1 #Heq
1885        whd in ⊢ ((???(???%)) → ?);
1886 #Henv #Hswrem #Henv'
1887#id   
1888*)
1889
1890(*
1891lemma substatement_fresh : ∀s,u.
1892    fresh_for_statement s u →
1893    substatement_P s (λs'. fresh_for_statement s' u) (λe. fresh_for_expression e u).
1894#s #u @(statement_ind2 ? (λls.fresh_for_labeled_statements ls u → substatement_ls ls (λs':statement.fresh_for_statement s' u)) … s)
1895try /by I/
1896[ 1: #e1 #e2 #H lapply (fresh_max_split … H) * #H1 #H2 whd @conj assumption
1897| 2: *
1898    [ 1: #e #args whd in ⊢ (% → %); #H lapply (fresh_max_split ??? H) *
1899         #Hfresh_e #Hfresh_args @conj try assumption
1900         normalize nodelta in Hfresh_args;
1901         >max_id_commutative in Hfresh_args; >max_id_one_neutral
1902         #Hfresh_args         
1903    | 2: #ret #e #args whd in ⊢ (% → %); #H lapply (fresh_max_split ??? H) *
1904         #Hfresh_e #H lapply (fresh_max_split ??? H) *
1905         #Hfresh_ret #Hfresh_args @conj try @conj try assumption ]
1906    elim args in Hfresh_args;
1907    [ 1,3: //
1908    | 2,4: #hd #tl #Hind whd in match (foldl ?????); whd in match (All ???);
1909            >foldl_max #H elim (fresh_max_split ??? H) #Hu #HAll @conj
1910            [ 1,3: @Hu
1911            | 2,4: @Hind assumption ] ]
1912| 3: #s1 #s2 #_ #_
1913     whd in ⊢ (% → ?); #H lapply (fresh_max_split … H) *
1914     whd in match (substatement_P ??); /2/
1915| 4: #e #cond #iftrue #iffalse #_
1916     whd in ⊢ (% → ?); #H lapply (fresh_max_split … H) *
1917     #Hexpr #H2 lapply (fresh_max_split … H2) * /2/
1918| 5,6: #e #stm #_
1919     whd in ⊢ (% → ?); #H lapply (fresh_max_split … H) * /2/
1920| 7: #init #cond #step #body #_ #_ #_ #H lapply (fresh_max_split … H) *
1921      #H1 #H2 elim (fresh_max_split … H1) #Hinit #Hcond
1922      elim (fresh_max_split … H2) #Hstep #Hbody whd @conj try @conj try @conj /3/
1923| 8: #ret #H whd elim ret in H; try //     
1924| 9: #expr #ls #Hind #H whd @conj
1925     [ 1: elim (fresh_max_split … H) //
1926     | 2: @Hind elim (fresh_max_split … H) // ]
1927| 10: #l #body #Hind #H whd elim (fresh_max_split … H) //
1928| 11: #sz #i #hd #tl #Hhd #Htl #H whd
1929     elim (fresh_max_split … H) #Htl_fresh #Hhd_fresh @conj //
1930     @Htl //
1931] qed.
1932*)
1933
1934(* Eliminating switches introduces fresh variables. [environment_extension] characterizes
1935 * a local environment extended by some local variables. *)
1936 
1937
1938(* lookup on environment extension *)
1939(*
1940lemma extension_lookup :
1941  ∀map, map', ext, id, result.
1942  environment_extension map map' ext →
1943  lookup ?? map id = Some ? result →
1944  lookup ?? map' id = Some ? result.
1945#map #map' #ext #id #result #Hext lapply (Hext id)
1946cases (mem_assoc_env ??) normalize nodelta
1947[ 1: * * #ext_result #H1 >H1 #Habsurd destruct (Habsurd)
1948| 2: #H >H // ] qed.
1949
1950*)
1951
1952(* Extending a map by an empty list of variables yields an observationally equivalent
1953 * environment. *)
1954(*
1955lemma environment_extension_nil : ∀en,en':env. (environment_extension en en' [ ]) → imap_eq ?? en en'.
1956* #map1 * #map2 whd in ⊢ (% → ?); #Hext whd % #id #v #H
1957[ 1: lapply (Hext (an_identifier ? id)) whd in match (lookup ????); normalize nodelta
1958     cases (lookup_opt block id map2) normalize
1959     [ 1: >H #H2 >H2 @refl
1960     | 2: #b >H cases v
1961          [ 1: normalize * #H @(False_ind … H)
1962          | 2: #block normalize // ] ]
1963| 2: lapply (Hext (an_identifier ? id)) whd in match (lookup ????); normalize nodelta
1964     >H cases v normalize try //
1965     #block cases (lookup_opt ? id map1) normalize try //
1966     * #H @(False_ind … H)
1967] qed. *)
1968
1969(* If two identifier maps are observationally equal, then they contain the same bocks.
1970 * see maps_obsequiv.ma for the details of the proof. *)
1971(*
1972lemma blocks_of_env_eq : ∀e,e'. imap_eq ?? e e' → blocks_of_env e = blocks_of_env e'.
1973* #map1 * #map2 normalize #Hpmap_eq lapply (pmap_eq_fold … Hpmap_eq) #Hfold
1974>Hfold @refl
1975qed.
1976*)
1977
1978(* Simulation relations. *)
1979inductive switch_cont_sim : (list ident) → cont → cont → Prop ≝
1980| swc_stop : ∀fvs.
1981    switch_cont_sim fvs Kstop Kstop
1982| swc_seq : ∀fvs,s,k,k',u,result.
1983    fresh_for_statement s u →
1984    switch_cont_sim fvs k k' →
1985    switch_removal s fvs u = Some ? result →
1986    switch_cont_sim fvs (Kseq s k) (Kseq (ret_st ? result) k')
1987| swc_while : ∀fvs,e,s,k,k',u,result.
1988    fresh_for_statement (Swhile e s) u →
1989    switch_cont_sim fvs k k' →
1990    switch_removal s fvs u = Some ? result →
1991    switch_cont_sim fvs (Kwhile e s k) (Kwhile e (ret_st ? result) k')
1992| swc_dowhile : ∀fvs,e,s,k,k',u,result.
1993    fresh_for_statement (Sdowhile e s) u →
1994    switch_cont_sim fvs k k' →
1995    switch_removal s fvs u = Some ? result →
1996    switch_cont_sim fvs (Kdowhile e s k) (Kdowhile e (ret_st ? result) k')
1997| swc_for1 : ∀fvs,e,s1,s2,k,k',u,result.
1998    fresh_for_statement (Sfor Sskip e s1 s2) u →
1999    switch_cont_sim fvs k k' →
2000    switch_removal (Sfor Sskip e s1 s2) fvs u = Some ? result →
2001    switch_cont_sim fvs (Kseq (Sfor Sskip e s1 s2) k) (Kseq (ret_st ? result) k')
2002| swc_for2 : ∀fvs,e,s1,s2,k,k',u,result1,result2.
2003    fresh_for_statement (Sfor Sskip e s1 s2) u →
2004    switch_cont_sim fvs k k' →
2005    switch_removal s1 fvs u = Some ? result1 →
2006    switch_removal s2 fvs (ret_u ? result1) = Some ? result2 →
2007    switch_cont_sim fvs (Kfor2 e s1 s2 k) (Kfor2 e (ret_st ? result1) (ret_st ? result2) k')
2008| swc_for3 : ∀fvs,e,s1,s2,k,k',u,result1,result2.
2009    fresh_for_statement (Sfor Sskip e s1 s2) u →
2010    switch_cont_sim fvs k k' →
2011    switch_removal s1 fvs u = Some ? result1 →
2012    switch_removal s2 fvs (ret_u ? result1) = Some ? result2 ->
2013    switch_cont_sim fvs (Kfor3 e s1 s2 k) (Kfor3 e (ret_st ? result1) (ret_st ? result2) k')
2014| swc_switch : ∀fvs,k,k'.
2015    switch_cont_sim fvs k k' →
2016    switch_cont_sim fvs (Kswitch k) (Kswitch k')
2017| swc_call : ∀fvs,en,en',r,f,k,k'. (* Warning: possible caveat with environments here. *)       
2018    switch_cont_sim fvs k k' →
2019    (* /!\ Update [en] with [fvs'] ... *)
2020    switch_cont_sim
2021      (map … (fst ??) (\snd (function_switch_removal f)))
2022      (Kcall r f en k)
2023      (Kcall r (\fst (function_switch_removal f)) en' k').
2024
2025
2026(*
2027 en' = exec_alloc_variables en m (\snd (function_switch_removal f))
2028 TODO : si variable héréditairement générée depuis [u], alors variable dans \snd (function_switch_removal f) et donc
2029        variable dans en'.
2030
2031        1) Pb: je voudrais que les noms générés dans (switch_removal s u) soient les mêmes que
2032           dans (function_switch_removal f). Pas faisable. Ce dont on a réellement besoin, c'est
2033           de savoir que :
2034           si je lookup une variable générée à partir d'un univers frais dans l'environement en',
2035           alors j'aurais un hit. L'environnement en' doit être à la fois fixe de step en step,
2036           et contenir tout ce qui est généré par u. Donc, on contraint u à etre "fresh for s"
2037           et à etre "(function_switch_removal f)-contained".
2038
2039        2) J'aurais surement besoin de l'hypothèse de freshness pour montrer que le lookup
2040           et l'update n'altèrent pas le comportement du reste du programme.
2041
2042        relation : si un statement S0 est inclus dans un statement S1, alors les variables générées
2043                   depuis tout freshgen u sur S0 sont inclus dans celles générées pour S1.
2044                   en particulier, si u est frais pour S1 u est frais pour S0.
2045
2046        Montrer que "environment_extension en en' (\snd (function_switch_removal f))" implique
2047                    "environment_extension en en' (\fst (\fst (switch_removal s u)))"
2048                   
2049 ---------------------------------------------------------------
2050 . constante de la transformation: exec_step laisse $en$ et $m$ invariants, sauf lors d'un appel de fonction
2051   et d'updates. Il est donc impossible d'allouer les variables sur [en] au fur et à mesure de leur génération.
2052   on doit donc utiliser l'env créé lors de l'allocation de la fonction. Conséquence directe : on doit donner
2053   en argument les freshgens qui correspondent à ce que la fonction switch_removal fait.
2054*)
2055
2056inductive switch_state_sim : state → state → Prop ≝
2057| sws_state : ∀u,f,s,k,k',m,m',result.
2058    ∀env, env', f', vars.
2059    ∀E:embedding.   
2060    ∀Hext:memory_ext E m m'.
2061    fresh_for_statement s u →
2062    (*
2063    env = \fst (exec_alloc_variables empty_env m ((fn_params f) @ (fn_vars f))) →
2064    env' = \fst (exec_alloc_variables empty_env m' ((fn_params f) @ vars @ (fn_vars f))) →
2065    *)
2066    〈f',vars〉 = function_switch_removal f →
2067    disjoint_extension env m env' m' vars E Hext →
2068    switch_removal s (map ?? (fst ??) vars) u = Some ? result →
2069    switch_cont_sim (map ?? (fst ??) vars) k k' →
2070    switch_state_sim
2071      (State f s k env m)
2072      (State f' (ret_st ? result) k' env' m')
2073| sws_callstate : ∀vars, fd,args,k,k',m.
2074    switch_cont_sim vars k k' →
2075    switch_state_sim (Callstate fd args k m) (Callstate (fundef_switch_removal fd) args k' m)
2076| sws_returnstate : ∀vars,res,k,k',m.
2077    switch_cont_sim vars k k' →
2078    switch_state_sim (Returnstate res k m) (Returnstate res k' m)
2079| sws_finalstate : ∀r.
2080    switch_state_sim (Finalstate r) (Finalstate r).
2081
2082lemma call_cont_swremoval : ∀fv,k,k'.
2083  switch_cont_sim fv k k' →
2084  switch_cont_sim fv (call_cont k) (call_cont k').
2085#fv #k0 #k0' #K elim K /2/
2086qed.
2087
2088(* [eventually ge P s tr] states that after a finite number of [exec_step], the
2089   property P on states will be verified. *)
2090inductive eventually (ge : genv) (P : state → Prop) : state → trace → Prop ≝
2091| eventually_base : ∀s,t,s'.
2092    exec_step ge s = Value io_out io_in ? 〈t, s'〉 →
2093    P s' →
2094    eventually ge P s t
2095| eventually_step : ∀s,t,s',t',trace.
2096    exec_step ge s = Value io_out io_in ? 〈t, s'〉 →
2097    eventually ge P s' t' →
2098    trace = (t ⧺ t') →
2099    eventually ge P s trace.
2100
2101(* [eventually] is not so nice to use directly, we would like to make the mandatory
2102 * [exec_step ge s = Value ??? 〈t, s'] visible - and in the end we would like not
2103   to give [s'] ourselves, but matita to compute it. Hence this little intro-wrapper. *)     
2104lemma eventually_now : ∀ge,P,s,t.
2105  (∃s'.exec_step ge s = Value io_out io_in ? 〈t,s'〉 ∧ P s') →
2106   eventually ge P s t.
2107#ge #P #s #t * #s' * #Hexec #HP %1{… Hexec HP}  (* %{E0} normalize >(append_nil ? t) %1{????? Hexec HP} *)
2108qed.
2109(*   
2110lemma eventually_now : ∀ge,P,s,t. (∃s'.exec_step ge s = Value io_out io_in ? 〈t,s'〉 ∧ P s') →
2111                                      ∃t'.eventually ge P s (t ⧺ t').
2112#ge #P #s #t * #s' * #Hexec #HP %{E0} normalize >(append_nil ? t) %1{????? Hexec HP}
2113qed.
2114*)
2115lemma eventually_later : ∀ge,P,s,t.
2116   (∃s',tstep.exec_step ge s = Value io_out io_in ? 〈tstep,s'〉 ∧ ∃tnext. t = tstep ⧺ tnext ∧ eventually ge P s' tnext) →
2117    eventually ge P s t.
2118#ge #P #s #t * #s' * #tstep * #Hexec_step * #tnext * #Heq #Heventually %2{s tstep s' tnext … Heq}
2119try assumption
2120qed.
2121
2122(* lift value_eq to option block *)
2123definition option_block_eq ≝ λE,ob1,ob2.
2124match ob1 with
2125[ None ⇒
2126  match ob2 with
2127  [ None ⇒ True
2128  | Some _ ⇒ False ]
2129| Some b1 ⇒
2130  match ob2 with
2131  [ None ⇒ False
2132  | Some b2 ⇒ value_eq E (Vptr (mk_pointer b1 zero_offset)) (Vptr (mk_pointer b2 zero_offset))  ]
2133].
2134
2135definition value_eq_opt ≝ λE,ov1,ov2.
2136match ov1 with
2137[ None ⇒
2138  match ov2 with
2139  [ None ⇒ True
2140  | Some _ ⇒ False ]
2141| Some v1 ⇒
2142  match ov2 with
2143  [ None ⇒ False
2144  | Some v2 ⇒
2145    value_eq E v1 v2 ]
2146].
2147
2148record switch_removal_globals (E : embedding) (F:Type[0]) (t:F → F) (ge:genv_t F) (ge':genv_t F) : Prop ≝ {
2149  rg_find_symbol: ∀s.
2150    option_block_eq E (find_symbol ? ge s) (find_symbol ? ge' s);
2151  rg_find_funct: ∀v,f.
2152    find_funct ? ge v = Some ? f →
2153    find_funct ? ge' v = Some ? (t f);
2154  rg_find_funct_ptr: ∀b,f.
2155    find_funct_ptr ? ge b = Some ? f →
2156    find_funct_ptr ? ge' b = Some ? (t f)
2157}.
2158
2159lemma exec_lvalue_expr_elim :
2160  ∀E,r1,r2,Pok,Qok.
2161  ∀H:exec_lvalue_sim E r1 r2.
2162  (∀bo1,bo2,tr.
2163    let 〈b1,o1〉 ≝ bo1 in
2164    let 〈b2,o2〉 ≝ bo2 in
2165    value_eq E (Vptr (mk_pointer b1 o1)) (Vptr (mk_pointer b2 o2)) →
2166    match Pok 〈bo1,tr〉 with
2167    [ Error err ⇒ True
2168    | OK vt1 ⇒
2169      let 〈val1,trace1〉 ≝ vt1 in
2170      match Qok 〈bo2,tr〉 with
2171      [ Error err ⇒ False
2172      | OK vt2 ⇒
2173        let 〈val2,trace2〉 ≝ vt2 in
2174        trace1 = trace2 ∧ value_eq E val1 val2     
2175      ]
2176    ]) →
2177  exec_expr_sim E
2178    (match r1 with [ OK x ⇒ Pok x | Error err ⇒ Error ? err ])
2179    (match r2 with [ OK x ⇒ Qok x | Error err ⇒ Error ? err ]).
2180#E #r1 #r2 #Pok #Qok whd in ⊢ (% → ?);
2181elim r1
2182[ 2: #error #_ #_ normalize #a1 #Habsurd destruct (Habsurd)
2183| 1: normalize nodelta #a1 #H lapply (H a1 (refl ??))
2184     * #a2 * #Hr2 >Hr2 normalize nodelta
2185     elim a1 * #b1 #o1 #tr1
2186     elim a2 * #b2 #o2 #tr2 normalize nodelta
2187     * #Hvalue_eq #Htrace_eq #H2
2188     destruct (Htrace_eq)
2189     lapply (H2 〈b1, o1〉 〈b2, o2〉 tr2 Hvalue_eq)
2190     cases (Pok 〈b1, o1, tr2〉)
2191     [ 2: #error #_ normalize #a1' #Habsurd destruct (Habsurd)
2192     | 1: * #v1 #tr1' normalize nodelta #H3 whd
2193          * #v1' #tr1'' #Heq destruct (Heq)
2194          cases (Qok 〈b2,o2,tr2〉) in H3;
2195          [ 2: #error #Hfalse @(False_ind … Hfalse)
2196          | 1: * #v2 #tr2 normalize nodelta * #Htrace_eq destruct (Htrace_eq)
2197               #Hvalue_eq' %{〈v2,tr2〉} @conj try @conj //
2198] ] ] qed.
2199
2200lemma exec_expr_expr_elim :
2201  ∀E,r1,r2,Pok,Qok.
2202  ∀H:exec_expr_sim E r1 r2.
2203  (∀v1,v2,trace.
2204    value_eq E v1 v2 →
2205    match Pok 〈v1,trace〉 with
2206    [ Error err ⇒ True
2207    | OK vt1 ⇒
2208      let 〈val1,trace1〉 ≝ vt1 in
2209      match Qok 〈v2,trace〉 with
2210      [ Error err ⇒ False
2211      | OK vt2 ⇒
2212        let 〈val2,trace2〉 ≝ vt2 in
2213        trace1 = trace2 ∧ value_eq E val1 val2     
2214      ]
2215    ]) →
2216  exec_expr_sim E
2217    (match r1 with [ OK x ⇒ Pok x | Error err ⇒ Error ? err ])
2218    (match r2 with [ OK x ⇒ Qok x | Error err ⇒ Error ? err ]).
2219#E #r1 #r2 #Pok #Qok whd in ⊢ (% → ?);
2220elim r1
2221[ 2: #error #_ #_ normalize #a1 #Habsurd destruct (Habsurd)
2222| 1: normalize nodelta #a1 #H lapply (H a1 (refl ??))
2223     * #a2 * #Hr2 >Hr2 normalize nodelta
2224     elim a1 #v1 #tr1
2225     elim a2 #v2 #tr2 normalize nodelta
2226     * #Hvalue_eq #Htrace_eq #H2
2227     destruct (Htrace_eq)
2228     lapply (H2 v1 v2 tr2 Hvalue_eq)
2229     cases (Pok 〈v1, tr2〉)
2230     [ 2: #error #_ normalize #a1' #Habsurd destruct (Habsurd)
2231     | 1: * #v1 #tr1' normalize nodelta #H3 whd
2232          * #v1' #tr1'' #Heq destruct (Heq)
2233          cases (Qok 〈v2,tr2〉) in H3;
2234          [ 2: #error #Hfalse @(False_ind … Hfalse)
2235          | 1: * #v2 #tr2 normalize nodelta * #Htrace_eq destruct (Htrace_eq)
2236               #Hvalue_eq' %{〈v2,tr2〉} @conj try @conj //
2237] ] ] qed.
2238
2239(* Commutation results of standard binary operations with value_eq. *)
2240lemma unary_operation_value_eq :
2241  ∀E,op,v1,v2,ty.
2242   value_eq E v1 v2 →
2243   ∀r1.
2244   sem_unary_operation op v1 ty = Some ? r1 →
2245    ∃r2.sem_unary_operation op v2 ty = Some ? r2 ∧ value_eq E r1 r2.
2246#E #op #v1 #v2 #ty #Hvalue_eq #r1
2247inversion Hvalue_eq
2248[ 1: #v #Hv1 #Hv2 #_ destruct
2249     cases op normalize
2250     [ 1: cases ty [ 1: | 2: #sz #sg | 3: #fl | 4: #ty | 5: #ty #n | 6: #tl #ty | 7: #id #fl | 8: #id #fl | 9: #ty ]
2251          normalize #Habsurd destruct (Habsurd)
2252     | 3: cases ty [ 1: | 2: #sz #sg | 3: #fl | 4: #ty | 5: #ty #n | 6: #tl #ty | 7: #id #fl | 8: #id #fl | 9: #ty ]
2253          normalize #Habsurd destruct (Habsurd)
2254     | 2: #Habsurd destruct (Habsurd) ]
2255| 2: #vsz #i #Hv1 #Hv2 #_
2256     cases op
2257     [ 1: cases ty
2258          [ 1: | 2: #sz #sg | 3: #fl | 4: #ty | 5: #ty #n | 6: #tl #ty | 7: #id #fl | 8: #id #fl | 9: #ty ]
2259          whd in ⊢ ((??%?) → ?); whd in match (sem_unary_operation ???);
2260          [ 2: cases (eq_intsize sz vsz) normalize nodelta #Heq1 destruct
2261               %{(of_bool (eq_bv (bitsize_of_intsize vsz) i (zero (bitsize_of_intsize vsz))))}
2262               cases (eq_bv (bitsize_of_intsize vsz) i (zero (bitsize_of_intsize vsz))) @conj
2263               //
2264          | *: #Habsurd destruct (Habsurd) ]
2265     | 2: whd in match (sem_unary_operation ???);     
2266          #Heq1 destruct %{(Vint vsz (exclusive_disjunction_bv (bitsize_of_intsize vsz) i (mone vsz)))} @conj //
2267     | 3: whd in match (sem_unary_operation ???);
2268          cases ty
2269          [ 1: | 2: #sz #sg | 3: #fl | 4: #ty | 5: #ty #n | 6: #tl #ty | 7: #id #fl | 8: #id #fl | 9: #ty ]
2270          normalize nodelta
2271          whd in ⊢ ((??%?) → ?);
2272          [ 2: cases (eq_intsize sz vsz) normalize nodelta #Heq1 destruct
2273               %{(Vint vsz (two_complement_negation (bitsize_of_intsize vsz) i))} @conj //
2274          | *: #Habsurd destruct (Habsurd) ] ]
2275| 3: #f #Hv1 #Hv2 #_ destruct  whd in match (sem_unary_operation ???);
2276     cases op normalize nodelta
2277     [ 1: cases ty
2278          [ 1: | 2: #sz #sg | 3: #fl | 4: #ty | 5: #ty #n | 6: #tl #ty | 7: #id #fl | 8: #id #fl | 9: #ty ]
2279          whd in match (sem_notbool ??);
2280          #Heq1 destruct
2281          cases (Fcmp Ceq f Fzero) /3 by ex_intro, vint_eq, conj/
2282     | 2: normalize #Habsurd destruct (Habsurd)
2283     | 3: cases ty
2284          [ 1: | 2: #sz #sg | 3: #fl | 4: #ty | 5: #ty #n | 6: #tl #ty | 7: #id #fl | 8: #id #fl | 9: #ty ]
2285          whd in match (sem_neg ??);
2286          #Heq1 destruct /3 by ex_intro, vfloat_eq, conj/ ]
2287| 4: #Hv1 #Hv2 #_ destruct  whd in match (sem_unary_operation ???);
2288     cases op normalize nodelta
2289     [ 1: cases ty
2290          [ 1: | 2: #sz #sg | 3: #fl | 4: #ty | 5: #ty #n | 6: #tl #ty | 7: #id #fl | 8: #id #fl | 9: #ty ]
2291          whd in match (sem_notbool ??);
2292          #Heq1 destruct /3 by ex_intro, vint_eq, conj/
2293     | 2: normalize #Habsurd destruct (Habsurd)
2294     | 3: cases ty
2295          [ 1: | 2: #sz #sg | 3: #fl | 4: #ty | 5: #ty #n | 6: #tl #ty | 7: #id #fl | 8: #id #fl | 9: #ty ]
2296          whd in match (sem_neg ??);
2297          #Heq1 destruct ]
2298| 5: #p1 #p2 #Hptr_translation #Hv1 #Hv2 #_  whd in match (sem_unary_operation ???);
2299     cases op normalize nodelta
2300     [ 1: cases ty
2301          [ 1: | 2: #sz #sg | 3: #fl | 4: #ty | 5: #ty #n | 6: #tl #ty | 7: #id #fl | 8: #id #fl | 9: #ty ]
2302          whd in match (sem_notbool ??);         
2303          #Heq1 destruct /3 by ex_intro, vint_eq, conj/
2304     | 2: normalize #Habsurd destruct (Habsurd)
2305     | 3: cases ty
2306          [ 1: | 2: #sz #sg | 3: #fl | 4: #ty | 5: #ty #n | 6: #tl #ty | 7: #id #fl | 8: #id #fl | 9: #ty ]
2307          whd in match (sem_neg ??);         
2308          #Heq1 destruct ]
2309]
2310qed.
2311
2312lemma commutative_add_with_carries : ∀n,a,b,carry. add_with_carries n a b carry = add_with_carries n b a carry.
2313#n elim n
2314[ 1: #a #b #carry
2315     lapply (BitVector_O … a) lapply (BitVector_O … b) #H1 #H2 destruct @refl
2316| 2: #n' #Hind #a #b #carry
2317     lapply (BitVector_Sn … a) lapply (BitVector_Sn … b)
2318     * #bhd * #btl #Heqb
2319     * #ahd * #atl #Heqa destruct
2320     lapply (Hind atl btl carry)
2321     whd in match (add_with_carries ????) in ⊢ ((??%%) →  (??%%));
2322     normalize in match (rewrite_l ??????);
2323     normalize nodelta
2324     #Heq >Heq
2325     generalize in match (fold_right2_i ????????); * #res #carries
2326     normalize nodelta
2327     cases ahd cases bhd @refl
2328] qed.
2329
2330   
2331lemma commutative_addition_n : ∀n,a,b. addition_n n a b = addition_n n b a.
2332#n #a #b whd in match (addition_n ???) in ⊢ (??%%); >commutative_add_with_carries
2333@refl
2334qed.
2335
2336(* -------------------------------------------------------------------------- *)
2337(* Associativity proof for addition_n. The proof relies on the observation
2338 * that the two carries (inner and outer) in the associativity equation are not
2339 * independent. In fact, the global carry can be encoded in a three-valued bits
2340 * (versus 2 full bits, i.e. 4 possibilites, for two carries). *)
2341
2342inductive ternary : Type[0] ≝
2343| Zero_carry : ternary
2344| One_carry : ternary
2345| Two_carry : ternary.
2346
2347definition carry_0 ≝ λcarry.
2348    match carry with
2349    [ Zero_carry ⇒ 〈false, Zero_carry〉
2350    | One_carry ⇒ 〈true, Zero_carry〉
2351    | Two_carry ⇒ 〈false, One_carry〉 ].
2352   
2353definition carry_1 ≝ λcarry.
2354    match carry with
2355    [ Zero_carry ⇒ 〈true, Zero_carry〉
2356    | One_carry ⇒ 〈false, One_carry〉
2357    | Two_carry ⇒ 〈true, One_carry〉 ].
2358
2359definition carry_2 ≝ λcarry.
2360    match carry with
2361    [ Zero_carry ⇒ 〈false, One_carry〉
2362    | One_carry ⇒ 〈true, One_carry〉
2363    | Two_carry ⇒ 〈false, Two_carry〉 ].
2364
2365definition carry_3 ≝ λcarry.
2366    match carry with
2367    [ Zero_carry ⇒ 〈true, One_carry〉
2368    | One_carry ⇒ 〈false, Two_carry〉
2369    | Two_carry ⇒ 〈true, Two_carry〉 ].
2370
2371(* Count the number of true bits in {xa,xb,xc} and compute the new bit along the new carry,
2372   according to the last one. *)
2373definition ternary_carry_of ≝ λxa,xb,xc,carry.
2374if xa then
2375  if xb then
2376    if xc then
2377      carry_3 carry
2378    else
2379      carry_2 carry
2380  else
2381    if xc then
2382      carry_2 carry
2383    else
2384      carry_1 carry
2385else
2386  if xb then
2387    if xc then
2388      carry_2 carry
2389    else
2390      carry_1 carry
2391  else
2392    if xc then
2393      carry_1 carry
2394    else
2395      carry_0 carry.
2396
2397let rec canonical_add (n : nat) (a,b,c : BitVector n) (init : ternary) on a : (BitVector n × ternary) ≝
2398match a in Vector return λsz.λ_. BitVector sz → BitVector sz → (BitVector sz × ternary) with
2399[ VEmpty ⇒ λ_,_. 〈VEmpty ?, init〉
2400| VCons sz' xa tla ⇒ λb',c'.
2401  let xb ≝ head' … b' in
2402  let xc ≝ head' … c' in
2403  let tlb ≝ tail … b' in
2404  let tlc ≝ tail … c' in
2405  let 〈bits, last〉 ≝ canonical_add ? tla tlb tlc init in
2406  let 〈bit, carry〉 ≝ ternary_carry_of xa xb xc last in
2407  〈bit ::: bits, carry〉
2408] b c.
2409
2410(* convert the classical carries (inner and outer) to ternary) *)
2411definition carries_to_ternary ≝ λcarry1,carry2.
2412  if carry1
2413  then if carry2
2414       then Two_carry
2415       else One_carry
2416  else if carry2
2417       then One_carry
2418       else Zero_carry.
2419   
2420lemma add_with_carries_Sn : ∀n,a_hd,a_tl,b_hd,b_tl,carry.
2421  add_with_carries (S n) (a_hd ::: a_tl) (b_hd ::: b_tl) carry =
2422   (let 〈lower_bits,carries〉 ≝ add_with_carries n a_tl b_tl carry in 
2423    let last_carry ≝
2424    match carries in Vector return λsz:ℕ.(λfoo:Vector bool sz.bool) with 
2425    [VEmpty⇒carry
2426    |VCons (sz:ℕ) (cy:bool) (tl:(Vector bool sz))⇒cy] 
2427    in 
2428    if last_carry then 
2429      let bit   ≝ xorb (xorb a_hd b_hd) true in 
2430      let carry ≝ carry_of a_hd b_hd true in 
2431      〈bit:::lower_bits,carry:::carries〉 
2432    else 
2433      let bit ≝ xorb (xorb a_hd b_hd) false in 
2434      let carry ≝ carry_of a_hd b_hd false in 
2435      〈bit:::lower_bits,carry:::carries〉).
2436#n #a_hd #a_tl #b_hd #b_tl #carry
2437whd in match (add_with_carries ????);
2438normalize nodelta
2439<add_with_carries_unfold
2440cases (add_with_carries n a_tl b_tl carry)
2441#lower_bits #carries normalize nodelta
2442elim n in a_tl b_tl lower_bits carries;
2443[ 1: #a_tl #b_tl #lower_bits #carries
2444     >(BitVector_O … carries) normalize nodelta
2445     cases carry normalize nodelta
2446     cases a_hd cases b_hd //
2447| 2: #n' #Hind #a_tl #b_tl #lower_bits #carries
2448     lapply (BitVector_Sn … carries) * #carries_hd * #carries_tl
2449     #Heq >Heq normalize nodelta
2450     cases carries_hd cases a_hd cases b_hd normalize nodelta
2451     //
2452] qed.
2453
2454(* Correction of [canonical_add], left side. Note the invariant on carries. *)
2455lemma canonical_add_left : ∀n,carry1,carry2,a,b,c.
2456  let 〈res_ab,flags_ab〉 ≝ add_with_carries n a b carry1 in
2457  let 〈res_ab_c,flags_ab_c〉 ≝ add_with_carries n res_ab c carry2 in
2458  let 〈res_canonical, last_carry〉 ≝ canonical_add ? a b c (carries_to_ternary carry1 carry2) in
2459  res_ab_c = res_canonical
2460  ∧ (match n return λx. BitVector x → BitVector x → Prop with
2461     [ O ⇒ λ_.λ_. True
2462     | S _ ⇒ λflags_ab',flags_ab_c'. carries_to_ternary (head' … flags_ab') (head' … flags_ab_c') = last_carry
2463     ] flags_ab flags_ab_c).
2464#n elim n
2465[ 1: #carry1 #carry2 #a #b #c >(BitVector_O … a) >(BitVector_O … b) >(BitVector_O … c) try @conj try //
2466| 2: #n' #Hind #carry1 #carry2 #a #b #c
2467     elim (BitVector_Sn … a) #xa * #a' #Heq_a
2468     elim (BitVector_Sn … b) #xb * #b' #Heq_b
2469     elim (BitVector_Sn … c) #xc * #c' #Heq_c
2470     lapply (Hind … carry1 carry2 a' b' c') -Hind
2471     destruct >add_with_carries_Sn
2472     elim (add_with_carries … a' b' carry1) #Hres_ab #Hflags_ab normalize nodelta
2473     lapply Hflags_ab lapply Hres_ab lapply c' lapply b' lapply a'
2474     -Hflags_ab -Hres_ab -c' -b' -a'
2475     cases n'
2476     [ 1: #a' #b' #c' #Hres_ab #Hflags_ab normalize nodelta
2477          >(BitVector_O … a') >(BitVector_O … b') >(BitVector_O … c')
2478          >(BitVector_O … Hres_ab) >(BitVector_O … Hflags_ab)
2479          normalize nodelta #_
2480          cases carry1 cases carry2 cases xa cases xb cases xc normalize @conj try //
2481     | 2: #n' #a' #b' #c' #Hres_ab #Hflags_ab normalize nodelta
2482          elim (BitVector_Sn … Hflags_ab) #hd_flags_ab * #tl_flags_ab #Heq_flags_ab >Heq_flags_ab
2483          normalize nodelta
2484          elim (BitVector_Sn … Hres_ab) #hd_res_ab * #tl_res_ab #Heq_res_ab >Heq_res_ab
2485          cases hd_flags_ab in Heq_flags_ab; #Heq_flags_ab normalize nodelta
2486          >add_with_carries_Sn
2487          elim (add_with_carries (S n') (hd_res_ab:::tl_res_ab) c' carry2) #res_ab_c #flags_ab_c
2488          normalize nodelta
2489          elim (BitVector_Sn … flags_ab_c) #hd_flags_ab_c * #tl_flags_ab_c #Heq_flags_ab_c >Heq_flags_ab_c
2490          normalize nodelta
2491          cases hd_flags_ab_c in Heq_flags_ab_c; #Heq_flags_ab_c
2492          normalize nodelta
2493          whd in match (canonical_add (S (S ?)) ? ? ? ?);
2494          whd in match (tail ???); whd in match (tail ???);
2495          elim (canonical_add (S n') a' b' c' (carries_to_ternary carry1 carry2)) #res_canonical #last_carry normalize
2496          * #Hres_ab_is_canonical #Hlast_carry <Hlast_carry normalize
2497          >Hres_ab_is_canonical
2498          cases xa cases xb cases xc try @conj try @refl
2499     ]
2500] qed.
2501
2502(* Symmetric. The two sides are most certainly doable in a single induction, but lazyness
2503   prevails over style.  *)
2504lemma canonical_add_right : ∀n,carry1,carry2,a,b,c.
2505  let 〈res_bc,flags_bc〉 ≝ add_with_carries n b c carry1 in
2506  let 〈res_a_bc,flags_a_bc〉 ≝ add_with_carries n a res_bc carry2 in
2507  let 〈res_canonical, last_carry〉 ≝ canonical_add ? a b c (carries_to_ternary carry1 carry2) in
2508  res_a_bc = res_canonical
2509  ∧ (match n return λx. BitVector x → BitVector x → Prop with
2510     [ O ⇒ λ_.λ_. True
2511     | S _ ⇒ λflags_bc',flags_a_bc'. carries_to_ternary (head' … flags_bc') (head' … flags_a_bc') = last_carry
2512     ] flags_bc flags_a_bc).
2513#n elim n
2514[ 1: #carry1 #carry2 #a #b #c >(BitVector_O … a) >(BitVector_O … b) >(BitVector_O … c) try @conj try //
2515| 2: #n' #Hind #carry1 #carry2 #a #b #c
2516     elim (BitVector_Sn … a) #xa * #a' #Heq_a
2517     elim (BitVector_Sn … b) #xb * #b' #Heq_b
2518     elim (BitVector_Sn … c) #xc * #c' #Heq_c
2519     lapply (Hind … carry1 carry2 a' b' c') -Hind
2520     destruct >add_with_carries_Sn
2521     elim (add_with_carries … b' c' carry1) #Hres_bc #Hflags_bc normalize nodelta
2522     lapply Hflags_bc lapply Hres_bc lapply c' lapply b' lapply a'
2523     -Hflags_bc -Hres_bc -c' -b' -a'
2524     cases n'
2525     [ 1: #a' #b' #c' #Hres_bc #Hflags_bc normalize nodelta
2526          >(BitVector_O … a') >(BitVector_O … b') >(BitVector_O … c')
2527          >(BitVector_O … Hres_bc) >(BitVector_O … Hflags_bc)
2528          normalize nodelta #_
2529          cases carry1 cases carry2 cases xa cases xb cases xc normalize @conj try //
2530     | 2: #n' #a' #b' #c' #Hres_bc #Hflags_bc normalize nodelta
2531          elim (BitVector_Sn … Hflags_bc) #hd_flags_bc * #tl_flags_bc #Heq_flags_bc >Heq_flags_bc
2532          normalize nodelta
2533          elim (BitVector_Sn … Hres_bc) #hd_res_bc * #tl_res_bc #Heq_res_bc >Heq_res_bc
2534          cases hd_flags_bc in Heq_flags_bc; #Heq_flags_bc normalize nodelta
2535          >add_with_carries_Sn
2536          elim (add_with_carries (S n') a' (hd_res_bc:::tl_res_bc) carry2) #res_a_bc #flags_a_bc
2537          normalize nodelta
2538          elim (BitVector_Sn … flags_a_bc) #hd_flags_a_bc * #tl_flags_a_bc #Heq_flags_a_bc >Heq_flags_a_bc
2539          normalize nodelta
2540          cases (hd_flags_a_bc) in Heq_flags_a_bc; #Heq_flags_a_bc
2541          whd in match (canonical_add (S (S ?)) ????);
2542          whd in match (tail ???); whd in match (tail ???);
2543          elim (canonical_add (S n') a' b' c' (carries_to_ternary carry1 carry2)) #res_canonical #last_carry normalize
2544          * #Hres_bc_is_canonical #Hlast_carry <Hlast_carry normalize
2545          >Hres_bc_is_canonical
2546          cases xa cases xb cases xc try @conj try @refl
2547     ]
2548] qed.
2549
2550
2551(* Note that we prove a result more general that just associativity: we can vary the carries. *)
2552lemma associative_add_with_carries :
2553  ∀n,carry1,carry2,a,b,c.
2554  (\fst (add_with_carries n a (let 〈res,flags〉 ≝ add_with_carries n b c carry1 in res) carry2))
2555   =
2556  (\fst (add_with_carries n (let 〈res,flags〉 ≝ add_with_carries n a b carry1 in res) c carry2)).
2557#n cases n
2558[ 1: #carry1 #carry2 #a #b #c
2559      >(BitVector_O … a) >(BitVector_O … b) >(BitVector_O … c)
2560      normalize try @refl
2561| 2: #n' #carry1 #carry2 #a #b #c
2562     lapply (canonical_add_left … carry1 carry2 a b c)
2563     lapply (canonical_add_right … carry1 carry2 a b c)
2564     normalize nodelta
2565     elim (add_with_carries (S n') b c carry1) #res_bc #flags_bc
2566     elim (add_with_carries (S n') a b carry1) #res_ab #flags_ab
2567     normalize nodelta
2568     elim (add_with_carries (S n') a res_bc carry2) #res_a_bc #flags_a_bc
2569     normalize nodelta     
2570     elim (add_with_carries (S n') res_ab c carry2) #res_ab_c #flags_ab_c
2571     normalize nodelta
2572     cases (canonical_add ? a b c (carries_to_ternary carry1 carry2)) #canonical_bits #last_carry
2573     normalize nodelta
2574     * #HA #HB * #HC #HD destruct @refl
2575] qed.
2576
2577(* This closes the proof of associativity for bitvector addition. *)     
2578
2579lemma associative_addition_n : ∀n,a,b,c. addition_n n a (addition_n n b c) = addition_n n (addition_n n a b) c.
2580#n #a #b #c
2581whd in match (addition_n ???) in ⊢ (??%%);
2582whd in match (addition_n n b c);
2583whd in match (addition_n n a b);
2584lapply (associative_add_with_carries … false false a b c)
2585elim (add_with_carries n b c false) #bc_bits #bc_flags
2586elim (add_with_carries n a b false) #ab_bits #ab_flags
2587normalize nodelta
2588elim (add_with_carries n a bc_bits false) #a_bc_bits #a_bc_flags
2589elim (add_with_carries n ab_bits c false) #ab_c_bits #ab_c_flags
2590normalize
2591#H @H
2592qed.
2593
2594
2595(* value_eq lifts to addition *)
2596lemma add_value_eq :
2597  ∀E,v1,v2,v1',v2',ty1,ty2.
2598   value_eq E v1 v2 →
2599   value_eq E v1' v2' →
2600   (* memory_inj E m1 m2 →  This injection seems useless TODO *)
2601   ∀r1. (sem_add v1 ty1 v1' ty2=Some val r1→
2602           ∃r2:val.sem_add v2 ty1 v2' ty2=Some val r2∧value_eq E r1 r2).
2603#E #v1 #v2 #v1' #v2' #ty1 #ty2 #Hvalue_eq1 #Hvalue_eq2 #r1
2604@(value_eq_inversion E … Hvalue_eq1)
2605[ 1: #v | 2: #sz #i | 3: #f | 4: | 5: #p1 #p2 #Hembed ]
2606[ 1: whd in match (sem_add ????); normalize nodelta
2607     cases (classify_add ty1 ty2) normalize nodelta
2608     [ 1: #sz #sg | 2: #fsz | 3: #n #ty #sz #sg | 4: #n #sz #sg #ty | 5: #ty1' #ty2' ]
2609     #Habsurd destruct (Habsurd)
2610| 2: whd in match (sem_add ????); whd in match (sem_add ????); normalize nodelta
2611     cases (classify_add ty1 ty2) normalize nodelta     
2612     [ 1: #tsz #tsg | 2: #tfsz | 3: #tn #ty #tsz #tsg | 4: #tn #tsz #tsg #ty | 5: #ty1' #ty2' ]
2613     [ 2,3,5: #Habsurd destruct (Habsurd) ]
2614     @(value_eq_inversion E … Hvalue_eq2) normalize nodelta
2615     [ 1,6: #v' | 2,7: #sz' #i' | 3,8: #f' | 4,9: | 5,10: #p1' #p2' #Hembed' ]
2616     [ 1,2,4,5,6,7,9: #Habsurd destruct (Habsurd) ]
2617     [ 1: @intsize_eq_elim_elim
2618          [ 1: #_ #Habsurd destruct (Habsurd)
2619          | 2: #Heq destruct (Heq) normalize nodelta
2620               #Heq destruct (Heq)
2621               /3 by ex_intro, conj, vint_eq/ ]
2622     | 2: @eq_bv_elim normalize nodelta #Heq1 #Heq2 destruct
2623          /3 by ex_intro, conj, vint_eq/
2624     | 3: #Heq destruct (Heq)
2625          normalize in Hembed'; elim p1' in Hembed'; #b1' #o1' normalize nodelta #Hembed
2626          %{(Vptr (shift_pointer_n (bitsize_of_intsize sz) p2' (sizeof ty) i))} @conj try @refl
2627          @vptr_eq whd in match (pointer_translation ??);
2628          cases (E b1') in Hembed;
2629          [ 1: normalize in ⊢ (% → ?); #Habsurd destruct (Habsurd)
2630          | 2: * #block #offset normalize nodelta #Heq destruct (Heq)
2631               whd in match (shift_pointer_n ????);
2632               cut (offset_plus (shift_offset_n (bitsize_of_intsize sz) o1' (sizeof ty) i) offset =
2633                    (shift_offset_n (bitsize_of_intsize sz) (mk_offset (addition_n ? (offv o1') (offv offset))) (sizeof ty) i))
2634               [ 1: whd in match (offset_plus ??);
2635                    whd in match (shift_offset_n ????) in ⊢ (??%%);
2636                    >commutative_addition_n >associative_addition_n
2637                    <(commutative_addition_n … (offv offset) (offv o1')) @refl ]
2638               #Heq >Heq @refl ]
2639     ]
2640| 3: whd in match (sem_add ????); whd in match (sem_add ????); normalize nodelta
2641     cases (classify_add ty1 ty2) normalize nodelta     
2642     [ 1: #tsz #tsg | 2: #tfsz | 3: #tn #ty #tsz #tsg | 4: #tn #tsz #tsg #ty | 5: #ty1' #ty2' ]
2643     [ 1,3,4,5: #Habsurd destruct (Habsurd) ]
2644     @(value_eq_inversion E … Hvalue_eq2) normalize nodelta
2645     [ 1: #v' | 2: #sz' #i' | 3: #f' | 4: | 5: #p1' #p2' #Hembed' ]
2646     [ 1,2,4,5: #Habsurd destruct (Habsurd) ]
2647     #Heq destruct (Heq)
2648     /3 by ex_intro, conj, vfloat_eq/
2649| 4: whd in match (sem_add ????); whd in match (sem_add ????); normalize nodelta
2650     cases (classify_add ty1 ty2) normalize nodelta     
2651     [ 1: #tsz #tsg | 2: #tfsz | 3: #tn #ty #tsz #tsg | 4: #tn #tsz #tsg #ty | 5: #ty1' #ty2' ]
2652     [ 1,2,4,5: #Habsurd destruct (Habsurd) ]
2653     @(value_eq_inversion E … Hvalue_eq2) normalize nodelta
2654     [ 1: #v' | 2: #sz' #i' | 3: #f' | 4: | 5: #p1' #p2' #Hembed' ]
2655     [ 1,3,4,5: #Habsurd destruct (Habsurd) ]
2656     @eq_bv_elim
2657     [ 1: normalize nodelta #Heq1 #Heq2 destruct /3 by ex_intro, conj, vnull_eq/
2658     | 2: #_ normalize nodelta #Habsurd destruct (Habsurd) ]
2659| 5: whd in match (sem_add ????); whd in match (sem_add ????); normalize nodelta
2660     cases (classify_add ty1 ty2) normalize nodelta
2661     [ 1: #tsz #tsg | 2: #tfsz | 3: #tn #ty #tsz #tsg | 4: #tn #tsz #tsg #ty | 5: #ty1' #ty2' ]
2662     [ 1,2,4,5: #Habsurd destruct (Habsurd) ]
2663     @(value_eq_inversion E … Hvalue_eq2) normalize nodelta
2664     [ 1: #v' | 2: #sz' #i' | 3: #f' | 4: | 5: #p1' #p2' #Hembed' ]
2665     [ 1,3,4,5: #Habsurd destruct (Habsurd) ]
2666     #Heq destruct (Heq)
2667     %{(Vptr (shift_pointer_n (bitsize_of_intsize sz') p2 (sizeof ty) i'))} @conj try @refl
2668     @vptr_eq whd in match (pointer_translation ??) in Hembed ⊢ %;
2669     elim p1 in Hembed; #b1 #o1 normalize nodelta
2670     cases (E b1)
2671     [ 1: normalize in ⊢ (% → ?); #Habsurd destruct (Habsurd)
2672     | 2: * #block #offset normalize nodelta #Heq destruct (Heq)
2673          whd in match (shift_pointer_n ????);
2674          whd in match (shift_offset_n ????) in ⊢ (??%%);
2675          whd in match (offset_plus ??);
2676          whd in match (offset_plus ??);
2677          >commutative_addition_n >(associative_addition_n … offset_size ?)
2678          >(commutative_addition_n ? (offv offset) ?) @refl
2679     ]
2680] qed.
2681       
2682lemma map_Sn : ∀A,B:Type[0].∀n,f,hd.∀tl:Vector A n.
2683  map A B (S n) f (hd ::: tl) = (f hd) ::: (map A B n f tl).
2684#A #B #n #f #hd #tl normalize @refl qed.
2685
2686lemma replicate_Sn : ∀A,sz,elt.
2687  replicate A (S sz) elt = elt ::: (replicate A sz elt).
2688// qed.
2689
2690lemma zero_Sn : ∀n. zero (S n) = false ::: (zero n). // qed.
2691
2692lemma negation_bv_Sn : ∀n. ∀xa. ∀a : BitVector n. negation_bv … (xa ::: a) = (notb xa) ::: (negation_bv … a).
2693#n #xa #a normalize @refl qed.
2694
2695
2696(* useful facts on xorb *)
2697
2698lemma xorb_neg : ∀a,b. notb (xorb a b) = xorb a (notb b). * * @refl qed.
2699lemma xorb_false : ∀a. xorb a false = a. * @refl qed.
2700lemma xorb_true : ∀a. xorb a true = (¬a). * @refl qed.
2701lemma xorb_comm : ∀a,b. xorb a b = xorb b a. * * @refl qed.
2702lemma xorb_assoc : ∀a,b,c. xorb a (xorb b c) = xorb (xorb a b) c. * * * @refl qed.
2703lemma xorb_lneg : ∀a,b. xorb (¬a) b = (¬xorb a b). * * @refl qed.
2704lemma xorb_rneg : ∀a,b. xorb a (¬b) = (¬xorb a b). * * @refl qed.
2705lemma xorb_inj : ∀a,b,c. xorb a b = xorb a c ↔ b = c. * * * @conj try // normalize try // qed.
2706
2707(* useful facts on carry_of *)
2708lemma carry_of_TT : ∀x. carry_of true true x = true. // qed.
2709lemma carry_of_TF : ∀x. carry_of true false x = x. // qed.
2710lemma carry_of_FF : ∀x. carry_of false false x = false. // qed.
2711lemma carry_of_lcomm : ∀x,y,z. carry_of x y z = carry_of y x z. * * * // qed.
2712lemma carry_of_rcomm : ∀x,y,z. carry_of x y z = carry_of x z y. * * * // qed.
2713
2714(* useful facts on various boolean operations *)
2715lemma andb_lsimpl_true : ∀x. andb true x = x. // qed.
2716lemma andb_lsimpl_false : ∀x. andb false x = false. normalize // qed.
2717lemma andb_comm : ∀x,y. andb x y = andb y x. // qed.
2718lemma notb_true : notb true = false. // qed.
2719lemma notb_false : notb false = true. % #H destruct qed.
2720lemma notb_fold : ∀x. if x then false else true = (¬x). // qed.
2721
2722(*
2723let rec one_bv (n : nat) on n : BitVector n ≝
2724match n return λx. BitVector x with
2725[ O ⇒ [[]]
2726| S x' ⇒
2727  match x' return λx. x = x' → BitVector (S x) with
2728  [ O ⇒ λ_. [[true]]
2729  | S x ⇒ λH. ? ] (refl ? x') ].
2730>H @(false ::: (one_bv x'))
2731qed.
2732*)
2733definition one_bv ≝ λn. (\fst (add_with_carries … (zero n) (zero n) true)).
2734
2735lemma one_bv_Sn_aux : ∀n. ∀bits,flags : BitVector (S n).
2736    add_with_carries … (zero (S n)) (zero (S n)) true = 〈bits, flags〉 →
2737    add_with_carries … (zero (S (S n))) (zero (S (S n))) true = 〈false ::: bits, false ::: flags〉.
2738#n elim n
2739[ 1: #bits #flags elim (BitVector_Sn … bits) #hd_bits * #tl_bits #Heq_bits
2740     elim (BitVector_Sn … flags) #hd_flags * #tl_flags #Heq_flags
2741     >(BitVector_O … tl_flags) >(BitVector_O … tl_bits)
2742     normalize #Heq destruct (Heq) @refl
2743| 2: #n' #Hind #bits #flags elim (BitVector_Sn … bits) #hd_bits * #tl_bits #Heq_bits
2744     destruct #Hind >add_with_carries_Sn >replicate_Sn
2745     whd in match (zero ?) in Hind; lapply Hind
2746     elim (add_with_carries (S (S n'))
2747            (false:::replicate bool (S n') false)
2748            (false:::replicate bool (S n') false) true) #bits #flags #Heq destruct
2749            normalize >add_with_carries_Sn in Hind;
2750     elim (add_with_carries (S n') (replicate bool (S n') false)
2751                    (replicate bool (S n') false) true) #flags' #bits'
2752     normalize
2753     cases (match bits' in Vector return λsz:ℕ.(λfoo:Vector bool sz.bool) with 
2754            [VEmpty⇒true|VCons (sz:ℕ)   (cy:bool)   (tl:(Vector bool sz))⇒cy])
2755     normalize #Heq destruct @refl
2756] qed.     
2757
2758lemma one_bv_Sn : ∀n. one_bv (S (S n)) = false ::: (one_bv (S n)).
2759#n lapply (one_bv_Sn_aux n)
2760whd in match (one_bv ?) in ⊢ (? → (??%%));
2761elim (add_with_carries (S n) (zero (S n)) (zero (S n)) true) #bits #flags
2762#H lapply (H bits flags (refl ??)) #H2 >H2 @refl
2763qed.
2764
2765lemma increment_to_addition_n_aux : ∀n. ∀a : BitVector n.
2766    add_with_carries ? a (zero n) true = add_with_carries ? a (one_bv n) false.
2767#n   
2768elim n
2769[ 1: #a >(BitVector_O … a) normalize @refl
2770| 2: #n' cases n'
2771     [ 1: #Hind #a elim (BitVector_Sn ? a) #xa * #tl #Heq destruct
2772          >(BitVector_O … tl) normalize cases xa @refl
2773     | 2: #n'' #Hind #a elim (BitVector_Sn ? a) #xa * #tl #Heq destruct
2774          >one_bv_Sn >zero_Sn
2775          lapply (Hind tl)
2776          >add_with_carries_Sn >add_with_carries_Sn
2777          #Hind >Hind elim (add_with_carries (S n'') tl (one_bv (S n'')) false) #bits #flags
2778          normalize nodelta elim (BitVector_Sn … flags) #flags_hd * #flags_tl #Hflags_eq >Hflags_eq
2779          normalize nodelta @refl
2780] qed.         
2781
2782(* In order to use associativity on increment, we hide it under addition_n. *)
2783lemma increment_to_addition_n : ∀n. ∀a : BitVector n. increment ? a = addition_n ? a (one_bv n).
2784#n
2785whd in match (increment ??) in ⊢ (∀_.??%?);
2786whd in match (addition_n ???) in ⊢ (∀_.???%);
2787#a lapply (increment_to_addition_n_aux n a)
2788#Heq >Heq cases (add_with_carries n a (one_bv n) false) #bits #flags @refl
2789qed.
2790
2791(* Explicit formulation of addition *)
2792
2793(* Explicit formulation of the last carry bit *)
2794let rec ith_carry (n : nat) (a,b : BitVector n) (init : bool) on n : bool ≝
2795match n return λx. BitVector x → BitVector x → bool with
2796[ O ⇒ λ_,_. init
2797| S x ⇒ λa',b'.
2798  let hd_a ≝ head' … a' in
2799  let hd_b ≝ head' … b' in
2800  let tl_a ≝ tail … a' in
2801  let tl_b ≝ tail … b' in
2802  carry_of hd_a hd_b (ith_carry x tl_a tl_b init)
2803] a b.
2804
2805lemma ith_carry_unfold : ∀n. ∀init. ∀a,b : BitVector (S n).
2806  ith_carry ? a b init = (carry_of (head' … a) (head' … b) (ith_carry ? (tail … a) (tail … b) init)).
2807#n #init #a #b @refl qed.
2808
2809lemma ith_carry_Sn : ∀n. ∀init. ∀xa,xb. ∀a,b : BitVector n.
2810  ith_carry ? (xa ::: a) (xb ::: b) init = (carry_of xa xb (ith_carry ? a b init)). // qed.
2811
2812(* correction of [ith_carry] *)
2813lemma ith_carry_ok : ∀n. ∀init. ∀a,b,res_ab,flags_ab : BitVector (S n).
2814  〈res_ab,flags_ab〉 = add_with_carries ? a b init →
2815  head' … flags_ab = ith_carry ? a b init.
2816#n elim n
2817[ 1: #init #a #b #res_ab #flags_ab
2818     elim (BitVector_Sn … a) #hd_a * #tl_a #Heq_a
2819     elim (BitVector_Sn … b) #hd_b * #tl_b #Heq_b
2820     elim (BitVector_Sn … res_ab) #hd_res * #tl_res #Heq_res
2821     elim (BitVector_Sn … flags_ab) #hd_flags * #tl_flags #Heq_flags
2822     destruct
2823     >(BitVector_O … tl_a) >(BitVector_O … tl_b)
2824     cases hd_a cases hd_b cases init normalize #Heq destruct (Heq)
2825     @refl
2826| 2: #n' #Hind #init #a #b #res_ab #flags_ab
2827     elim (BitVector_Sn … a) #hd_a * #tl_a #Heq_a
2828     elim (BitVector_Sn … b) #hd_b * #tl_b #Heq_b
2829     elim (BitVector_Sn … res_ab) #hd_res * #tl_res #Heq_res
2830     elim (BitVector_Sn … flags_ab) #hd_flags * #tl_flags #Heq_flags
2831     destruct
2832     lapply (Hind … init tl_a tl_b tl_res tl_flags)
2833     >add_with_carries_Sn >(ith_carry_Sn (S n'))
2834     elim (add_with_carries (S n') tl_a tl_b init) #res_ab #flags_ab
2835     elim (BitVector_Sn … flags_ab) #hd_flags_ab * #tl_flags_ab #Heq_flags_ab >Heq_flags_ab
2836     normalize nodelta cases hd_flags_ab normalize nodelta
2837     whd in match (head' ? (S n') ?); #H1 #H2
2838     destruct (H2) lapply (H1 (refl ??)) whd in match (head' ???); #Heq <Heq @refl
2839] qed.
2840
2841(* Explicit formulation of ith bit of an addition, with explicit initial carry bit. *)
2842definition ith_bit ≝ λ(n : nat).λ(a,b : BitVector n).λinit.
2843match n return λx. BitVector x → BitVector x → bool with
2844[ O ⇒ λ_,_. init
2845| S x ⇒ λa',b'.
2846  let hd_a ≝ head' … a' in
2847  let hd_b ≝ head' … b' in
2848  let tl_a ≝ tail … a' in
2849  let tl_b ≝ tail … b' in
2850  xorb (xorb hd_a hd_b) (ith_carry x tl_a tl_b init)
2851] a b.
2852
2853lemma ith_bit_unfold : ∀n. ∀init. ∀a,b : BitVector (S n).
2854  ith_bit ? a b init =  xorb (xorb (head' … a) (head' … b)) (ith_carry ? (tail … a) (tail … b) init).
2855#n #a #b // qed.
2856
2857lemma ith_bit_Sn : ∀n. ∀init. ∀xa,xb. ∀a,b : BitVector n.
2858  ith_bit ? (xa ::: a) (xb ::: b) init =  xorb (xorb xa xb) (ith_carry ? a b init). // qed.
2859
2860(* correction of ith_bit *)
2861lemma ith_bit_ok : ∀n. ∀init. ∀a,b,res_ab,flags_ab : BitVector (S n).
2862  〈res_ab,flags_ab〉 = add_with_carries ? a b init →
2863  head' … res_ab = ith_bit ? a b init.
2864#n
2865cases n
2866[ 1: #init #a #b #res_ab #flags_ab
2867     elim (BitVector_Sn … a) #hd_a * #tl_a #Heq_a
2868     elim (BitVector_Sn … b) #hd_b * #tl_b #Heq_b
2869     elim (BitVector_Sn … res_ab) #hd_res * #tl_res #Heq_res
2870     elim (BitVector_Sn … flags_ab) #hd_flags * #tl_flags #Heq_flags
2871     destruct
2872     >(BitVector_O … tl_a) >(BitVector_O … tl_b)
2873     >(BitVector_O … tl_flags) >(BitVector_O … tl_res)
2874     normalize cases init cases hd_a cases hd_b normalize #Heq destruct @refl
2875| 2: #n' #init #a #b #res_ab #flags_ab
2876     elim (BitVector_Sn … a) #hd_a * #tl_a #Heq_a
2877     elim (BitVector_Sn … b) #hd_b * #tl_b #Heq_b
2878     elim (BitVector_Sn … res_ab) #hd_res * #tl_res #Heq_res
2879     elim (BitVector_Sn … flags_ab) #hd_flags * #tl_flags #Heq_flags
2880     destruct
2881     lapply (ith_carry_ok … init tl_a tl_b tl_res tl_flags)
2882     #Hcarry >add_with_carries_Sn elim (add_with_carries ? tl_a tl_b init) in Hcarry;
2883     #res #flags normalize nodelta elim (BitVector_Sn … flags) #hd_flags' * #tl_flags' #Heq_flags'
2884     >Heq_flags' normalize nodelta cases hd_flags' normalize nodelta #H1 #H2 destruct (H2)
2885     cases hd_a cases hd_b >ith_bit_Sn whd in match (head' ???) in H1 ⊢ %;
2886     <(H1 (refl ??)) @refl
2887] qed.
2888
2889(* Transform a function from bit-vectors to bits into a vector by folding *)
2890let rec bitvector_fold (n : nat) (v : BitVector n) (f : ∀sz. BitVector sz → bool) on v : BitVector n ≝
2891match v with
2892[ VEmpty ⇒ VEmpty ?
2893| VCons sz elt tl ⇒
2894  let bit ≝ f ? v in
2895  bit ::: (bitvector_fold ? tl f)
2896].
2897
2898(* Two-arguments version *)
2899let rec bitvector_fold2 (n : nat) (v1, v2 : BitVector n) (f : ∀sz. BitVector sz → BitVector sz → bool) on v1 : BitVector n ≝
2900match v1  with
2901[ VEmpty ⇒ λ_. VEmpty ?
2902| VCons sz elt tl ⇒ λv2'.
2903  let bit ≝ f ? v1 v2 in
2904  bit ::: (bitvector_fold2 ? tl (tail … v2') f)
2905] v2.
2906
2907lemma bitvector_fold2_Sn : ∀n,x1,x2,v1,v2,f.
2908  bitvector_fold2 (S n) (x1 ::: v1) (x2 ::: v2) f = (f ? (x1 ::: v1) (x2 ::: v2)) ::: (bitvector_fold2 … v1 v2 f). // qed.
2909
2910(* These functions pack all the relevant information (including carries) directly. *)
2911definition addition_n_direct ≝ λn,v1,v2,init. bitvector_fold2 n v1 v2 (λn,v1,v2. ith_bit n v1 v2 init).
2912
2913lemma addition_n_direct_Sn : ∀n,x1,x2,v1,v2,init.
2914  addition_n_direct (S n) (x1 ::: v1) (x2 ::: v2) init = (ith_bit ? (x1 ::: v1) (x2 ::: v2) init) ::: (addition_n_direct … v1 v2 init). // qed.
2915 
2916lemma tail_Sn : ∀n. ∀x. ∀a : BitVector n. tail … (x ::: a) = a. // qed.
2917
2918(* Prove the equivalence of addition_n_direct with add_with_carries *)
2919lemma addition_n_direct_ok : ∀n,carry,v1,v2.
2920  (\fst (add_with_carries n v1 v2 carry)) = addition_n_direct n v1 v2 carry.
2921#n elim n
2922[ 1: #carry #v1 #v2 >(BitVector_O … v1) >(BitVector_O … v2) normalize @refl
2923| 2: #n' #Hind #carry #v1 #v2
2924     elim (BitVector_Sn … v1) #hd1 * #tl1 #Heq1
2925     elim (BitVector_Sn … v2) #hd2 * #tl2 #Heq2
2926     lapply (Hind carry tl1 tl2)
2927     lapply (ith_bit_ok ? carry v1 v2)
2928     lapply (ith_carry_ok ? carry v1 v2)
2929     destruct
2930     #Hind >addition_n_direct_Sn
2931     >ith_bit_Sn >add_with_carries_Sn
2932     elim (add_with_carries n' tl1 tl2 carry) #bits #flags normalize nodelta
2933     cases (match flags in Vector return λsz:ℕ.(λfoo:Vector bool sz.bool) with 
2934            [VEmpty⇒carry|VCons (sz:ℕ)   (cy:bool)   (tl:(Vector bool sz))⇒cy])
2935     normalize nodelta #Hcarry' lapply (Hcarry' ?? (refl ??))
2936     whd in match head'; normalize nodelta
2937     #H1 #H2 >H1 >H2 @refl
2938] qed.
2939 
2940(* trivially lift associativity to our new setting *)     
2941lemma associative_addition_n_direct : ∀n. ∀carry1,carry2. ∀v1,v2,v3 : BitVector n.
2942  addition_n_direct ? (addition_n_direct ? v1 v2 carry1) v3 carry2 =
2943  addition_n_direct ? v1 (addition_n_direct ? v2 v3 carry1) carry2.
2944#n #carry1 #carry2 #v1 #v2 #v3
2945<addition_n_direct_ok <addition_n_direct_ok
2946<addition_n_direct_ok <addition_n_direct_ok
2947lapply (associative_add_with_carries … carry1 carry2 v1 v2 v3)
2948elim (add_with_carries n v2 v3 carry1) #bits #carries normalize nodelta
2949elim (add_with_carries n v1 v2 carry1) #bits' #carries' normalize nodelta
2950#H @(sym_eq … H)
2951qed.
2952
2953lemma commutative_addition_n_direct : ∀n. ∀v1,v2 : BitVector n.
2954  addition_n_direct ? v1 v2 false = addition_n_direct ? v2 v1 false.
2955#n #v1 #v2 /by associative_addition_n, addition_n_direct_ok/
2956qed.
2957
2958definition increment_direct ≝ λn,v. addition_n_direct n v (one_bv ?) false.
2959definition twocomp_neg_direct ≝ λn,v. increment_direct n (negation_bv n v).
2960
2961(* fold andb on a bitvector. *)
2962let rec andb_fold (n : nat) (b : BitVector n) on b : bool ≝
2963match b with
2964[ VEmpty ⇒ true
2965| VCons sz elt tl ⇒
2966  andb elt (andb_fold ? tl)
2967].
2968
2969lemma andb_fold_Sn : ∀n. ∀x. ∀b : BitVector n. andb_fold (S n) (x ::: b) = andb x (andb_fold … n b). // qed.
2970
2971lemma andb_fold_inversion : ∀n. ∀elt,x. andb_fold (S n) (elt ::: x) = true → elt = true ∧ andb_fold n x = true.
2972#n #elt #x cases elt normalize #H @conj destruct (H) try assumption @refl
2973qed.
2974
2975lemma ith_increment_carry : ∀n. ∀a : BitVector (S n).
2976  ith_carry … a (one_bv ?) false = andb_fold … a.
2977#n elim n
2978[ 1: #a elim (BitVector_Sn … a) #hd * #tl #Heq >Heq >(BitVector_O … tl)
2979     cases hd normalize @refl
2980| 2: #n' #Hind #a
2981     elim (BitVector_Sn … a) #hd * #tl #Heq >Heq
2982     lapply (Hind … tl) #Hind >one_bv_Sn
2983     >ith_carry_Sn whd in match (andb_fold ??);
2984     cases hd >Hind @refl
2985] qed.
2986
2987lemma ith_increment_bit : ∀n. ∀a : BitVector (S n).
2988  ith_bit … a (one_bv ?) false = xorb (head' … a) (andb_fold … (tail … a)).
2989#n #a
2990elim (BitVector_Sn … a) #hd * #tl #Heq >Heq
2991whd in match (head' ???);
2992-a cases n in tl;
2993[ 1: #tl >(BitVector_O … tl) cases hd normalize try //
2994| 2: #n' #tl >one_bv_Sn >ith_bit_Sn
2995     >ith_increment_carry >tail_Sn
2996     cases hd try //
2997] qed.
2998
2999(* Lemma used to prove involutivity of two-complement negation *)
3000lemma twocomp_neg_involutive_aux : ∀n. ∀v : BitVector (S n).
3001   (andb_fold (S n) (negation_bv (S n) v) =
3002    andb_fold (S n) (negation_bv (S n) (addition_n_direct (S n) (negation_bv (S n) v) (one_bv (S n)) false))).
3003#n elim n
3004[ 1: #v elim (BitVector_Sn … v) #hd * #tl #Heq >Heq >(BitVector_O … tl) cases hd @refl
3005| 2: #n' #Hind #v elim (BitVector_Sn … v) #hd * #tl #Heq >Heq
3006     lapply (Hind tl) -Hind #Hind >negation_bv_Sn >one_bv_Sn >addition_n_direct_Sn
3007     >andb_fold_Sn >ith_bit_Sn >negation_bv_Sn >andb_fold_Sn <Hind
3008     cases hd normalize nodelta
3009     [ 1: >xorb_false >(xorb_comm false ?) >xorb_false
3010     | 2: >xorb_false >(xorb_comm true ?) >xorb_true ]
3011     >ith_increment_carry
3012     cases (andb_fold (S n') (negation_bv (S n') tl)) @refl
3013] qed.
3014   
3015(* Test of the 'direct' approach: proof of the involutivity of two-complement negation. *)
3016lemma twocomp_neg_involutive : ∀n. ∀v : BitVector n. twocomp_neg_direct ? (twocomp_neg_direct ? v) = v.
3017#n elim n
3018[ 1: #v >(BitVector_O v) @refl
3019| 2: #n' cases n'
3020     [ 1: #Hind #v elim (BitVector_Sn … v) #hd * #tl #Heq >Heq
3021          >(BitVector_O … tl) normalize cases hd @refl
3022     | 2: #n'' #Hind #v elim (BitVector_Sn … v) #hd * #tl #Heq >Heq
3023          lapply (Hind tl) -Hind #Hind <Hind in ⊢ (???%);
3024          whd in match twocomp_neg_direct; normalize nodelta
3025          whd in match increment_direct; normalize nodelta
3026          >(negation_bv_Sn ? hd tl) >one_bv_Sn >(addition_n_direct_Sn ? (¬hd) false ??)
3027          >ith_bit_Sn >negation_bv_Sn >addition_n_direct_Sn >ith_bit_Sn
3028          generalize in match (addition_n_direct (S n'')
3029                                                   (negation_bv (S n'')
3030                                                   (addition_n_direct (S n'') (negation_bv (S n'') tl) (one_bv (S n'')) false))
3031                                                   (one_bv (S n'')) false); #tail
3032          >ith_increment_carry >ith_increment_carry
3033          cases hd normalize nodelta
3034          [ 1: normalize in match (xorb false false); >(xorb_comm false ?) >xorb_false >xorb_false
3035          | 2: normalize in match (xorb true false); >(xorb_comm true ?) >xorb_true >xorb_false ]
3036          <twocomp_neg_involutive_aux
3037          cases (andb_fold (S n'') (negation_bv (S n'') tl)) @refl
3038      ]
3039] qed.
3040
3041lemma bitvector_cons_inj_inv : ∀n. ∀a,b. ∀va,vb : BitVector n. a ::: va = b ::: vb → a =b ∧ va = vb.
3042#n #a #b #va #vb #H destruct (H) @conj @refl qed.
3043
3044lemma bitvector_cons_eq : ∀n. ∀a,b. ∀v : BitVector n. a = b → a ::: v = b ::: v. // qed.
3045
3046(* Injectivity of increment *)
3047lemma increment_inj : ∀n. ∀a,b : BitVector n.
3048  increment_direct ? a = increment_direct ? b →
3049  a = b ∧ (ith_carry n a (one_bv n) false = ith_carry n b (one_bv n) false).
3050#n whd in match increment_direct; normalize nodelta elim n
3051[ 1: #a #b >(BitVector_O … a) >(BitVector_O … b) normalize #_ @conj //
3052| 2: #n' cases n'
3053   [ 1: #_ #a #b
3054        elim (BitVector_Sn … a) #hd_a * #tl_a #Heq_a >Heq_a
3055        elim (BitVector_Sn … b) #hd_b * #tl_b #Heq_b >Heq_b
3056        >(BitVector_O … tl_a) >(BitVector_O … tl_b) cases hd_a cases hd_b
3057        normalize #H @conj try //
3058   | 2: #n'' #Hind #a #b
3059        elim (BitVector_Sn … a) #hd_a * #tl_a #Heq_a >Heq_a
3060        elim (BitVector_Sn … b) #hd_b * #tl_b #Heq_b >Heq_b
3061        lapply (Hind … tl_a tl_b) -Hind #Hind
3062        >one_bv_Sn >addition_n_direct_Sn >ith_bit_Sn
3063        >addition_n_direct_Sn >ith_bit_Sn >xorb_false >xorb_false
3064        #H elim (bitvector_cons_inj_inv … H) #Heq1 #Heq2
3065        lapply (Hind Heq2) * #Heq3 #Heq4
3066        cut (hd_a = hd_b)
3067        [ 1: >Heq4 in Heq1; #Heq5 lapply (xorb_inj (ith_carry ? tl_b (one_bv ?) false) hd_a hd_b)
3068             * #Heq6 #_ >xorb_comm in Heq6; >(xorb_comm  ? hd_b) #Heq6 >(Heq6 Heq5)
3069             @refl ]
3070        #Heq5 @conj [ 1: >Heq3 >Heq5 @refl ]
3071        >ith_carry_Sn >ith_carry_Sn >Heq4 >Heq5 @refl
3072] qed.
3073
3074(* Inverse of injecivity of increment, does not lose information (cf increment_inj) *)
3075lemma increment_inj_inv : ∀n. ∀a,b : BitVector n.
3076  a = b → increment_direct ? a = increment_direct ? b. // qed.
3077
3078lemma carry_notb : ∀a,b,c. notb (carry_of a b c) = carry_of (notb a) (notb b) (notb c). * * * @refl qed.
3079
3080lemma increment_to_carry_aux : ∀n. ∀a : BitVector (S n).
3081   ith_carry (S n) a (one_bv (S n)) false
3082   = ith_carry (S n) a (zero (S n)) true.
3083#n elim n
3084[ 1: #a elim (BitVector_Sn ? a) #hd_a * #tl_a #Heq >Heq >(BitVector_O … tl_a) @refl
3085| 2: #n' #Hind #a elim (BitVector_Sn ? a) #hd_a * #tl_a #Heq >Heq
3086     lapply (Hind tl_a) #Hind
3087     >one_bv_Sn >zero_Sn >ith_carry_Sn >ith_carry_Sn >Hind @refl
3088] qed.
3089
3090lemma neutral_addition_n_direct_aux : ∀n. ∀v. ith_carry n v (zero n) false = false.
3091#n elim n //
3092#n' #Hind #v elim (BitVector_Sn … v) #hd * #tl #Heq >Heq >zero_Sn
3093>ith_carry_Sn >(Hind tl) cases hd @refl.
3094qed.
3095
3096lemma neutral_addition_n_direct : ∀n. ∀v : BitVector n.
3097  addition_n_direct ? v (zero ?) false = v.
3098#n elim n
3099[ 1: #v >(BitVector_O … v) normalize @refl
3100| 2: #n' #Hind #v elim (BitVector_Sn … v) #hd * #tl #Heq >Heq
3101     lapply (Hind … tl) #H >zero_Sn >addition_n_direct_Sn
3102     >ith_bit_Sn >H >xorb_false >neutral_addition_n_direct_aux
3103     >xorb_false @refl
3104] qed.
3105
3106lemma increment_to_carry_zero : ∀n. ∀a : BitVector n. addition_n_direct ? a (one_bv ?) false = addition_n_direct ? a (zero ?) true.
3107#n elim n
3108[ 1: #a >(BitVector_O … a) normalize @refl
3109| 2: #n' cases n'
3110     [ 1: #_ #a elim (BitVector_Sn … a) #hd_a * #tl_a #Heq >Heq >(BitVector_O … tl_a) cases hd_a @refl
3111     | 2: #n'' #Hind #a
3112          elim (BitVector_Sn … a) #hd_a * #tl_a #Heq >Heq
3113          lapply (Hind tl_a) -Hind #Hind
3114          >one_bv_Sn >zero_Sn >addition_n_direct_Sn >ith_bit_Sn
3115          >addition_n_direct_Sn >ith_bit_Sn
3116          >xorb_false >Hind @bitvector_cons_eq
3117          >increment_to_carry_aux @refl
3118     ]
3119] qed.
3120
3121lemma increment_to_carry : ∀n. ∀a,b : BitVector n.
3122  addition_n_direct ? a (addition_n_direct ? b (one_bv ?) false) false = addition_n_direct ? a b true.
3123#n #a #b >increment_to_carry_zero <associative_addition_n_direct
3124>neutral_addition_n_direct @refl
3125qed.
3126
3127(* Prove -(a + b) = -a + -b *)
3128lemma twocomp_neg_plus : ∀n. ∀a,b : BitVector n.
3129  twocomp_neg_direct ? (addition_n_direct ? a b false) = addition_n_direct ? (twocomp_neg_direct … a) (twocomp_neg_direct … b) false.
3130whd in match twocomp_neg_direct; normalize nodelta
3131lapply increment_inj_inv
3132whd in match increment_direct; normalize nodelta
3133#H #n #a #b
3134<associative_addition_n_direct @H
3135>associative_addition_n_direct >(commutative_addition_n_direct ? (one_bv n))
3136>increment_to_carry
3137-H lapply b lapply a -b -a
3138cases n
3139[ 1: #a #b >(BitVector_O … a) >(BitVector_O … b) @refl
3140| 2: #n' #a #b
3141     cut (negation_bv ? (addition_n_direct ? a b false)
3142           = addition_n_direct ? (negation_bv ? a) (negation_bv ? b) true ∧
3143          notb (ith_carry ? a b false) = (ith_carry ? (negation_bv ? a) (negation_bv ? b) true))
3144     [ -n lapply b lapply a elim n'
3145     [ 1: #a #b elim (BitVector_Sn … a) #hd_a * #tl_a #Heqa >Heqa >(BitVector_O … tl_a)
3146          elim (BitVector_Sn … b) #hd_b * #tl_b #Heqb >Heqb >(BitVector_O … tl_b)
3147          cases hd_a cases hd_b normalize @conj @refl
3148     | 2: #n #Hind #a #b
3149          elim (BitVector_Sn … a) #hd_a * #tl_a #Heqa >Heqa
3150          elim (BitVector_Sn … b) #hd_b * #tl_b #Heqb >Heqb
3151          lapply (Hind tl_a tl_b) * #H1 #H2
3152          @conj
3153          [ 2: >ith_carry_Sn >negation_bv_Sn >negation_bv_Sn >ith_carry_Sn
3154               >carry_notb >H2 @refl
3155          | 1: >addition_n_direct_Sn >ith_bit_Sn >negation_bv_Sn
3156               >negation_bv_Sn >negation_bv_Sn
3157               >addition_n_direct_Sn >ith_bit_Sn >H1 @bitvector_cons_eq
3158               >xorb_lneg >xorb_rneg >notb_notb
3159               <xorb_rneg >H2 @refl
3160          ]
3161      ] ]
3162      * #H1 #H2 @H1
3163] qed.
3164
3165lemma addition_n_direct_neg : ∀n. ∀a.
3166 (addition_n_direct n a (negation_bv n a) false) = replicate ?? true
3167 ∧ (ith_carry n a (negation_bv n a) false = false).
3168#n elim n
3169[ 1: #a >(BitVector_O … a) @conj @refl
3170| 2: #n' #Hind #a elim (BitVector_Sn … a) #hd * #tl #Heq >Heq
3171     lapply (Hind … tl) -Hind * #HA #HB
3172     @conj
3173     [ 2: >negation_bv_Sn >ith_carry_Sn >HB cases hd @refl
3174     | 1: >negation_bv_Sn >addition_n_direct_Sn
3175          >ith_bit_Sn >HB >xorb_false >HA
3176          @bitvector_cons_eq elim hd @refl
3177     ]
3178] qed.     
3179
3180(* -a + a = 0 *)
3181lemma bitvector_opp_direct : ∀n. ∀a : BitVector n. addition_n_direct ? a (twocomp_neg_direct ? a) false = (zero ?).
3182whd in match twocomp_neg_direct;
3183whd in match increment_direct;
3184normalize nodelta
3185#n #a <associative_addition_n_direct
3186elim (addition_n_direct_neg … a) #H #_ >H
3187-H -a
3188cases n try //
3189#n'
3190cut ((addition_n_direct (S n') (replicate bool ? true) (one_bv ?) false = (zero (S n')))
3191       ∧ (ith_carry ? (replicate bool (S n') true) (one_bv (S n')) false = true))
3192[ elim n'
3193     [ 1: @conj @refl
3194     | 2: #n' * #HA #HB @conj
3195          [ 1: >replicate_Sn >one_bv_Sn  >addition_n_direct_Sn
3196               >ith_bit_Sn >HA >zero_Sn @bitvector_cons_eq >HB @refl
3197          | 2: >replicate_Sn >one_bv_Sn >ith_carry_Sn >HB @refl ]
3198     ]
3199] * #H1 #H2 @H1
3200qed.
3201
3202(* Lift back the previous result to standard operations. *)
3203lemma twocomp_neg_direct_ok : ∀n. ∀v. twocomp_neg_direct ? v = two_complement_negation n v.
3204#n #v whd in match twocomp_neg_direct; normalize nodelta
3205whd in match increment_direct; normalize nodelta
3206whd in match two_complement_negation; normalize nodelta
3207>increment_to_addition_n <addition_n_direct_ok
3208whd in match addition_n; normalize nodelta
3209elim (add_with_carries ????) #a #b @refl
3210qed.
3211
3212lemma two_complement_negation_plus : ∀n. ∀a,b : BitVector n.
3213  two_complement_negation ? (addition_n ? a b) = addition_n ? (two_complement_negation ? a) (two_complement_negation ? b).
3214#n #a #b
3215lapply (twocomp_neg_plus ? a b)
3216>twocomp_neg_direct_ok >twocomp_neg_direct_ok >twocomp_neg_direct_ok
3217<addition_n_direct_ok <addition_n_direct_ok
3218whd in match addition_n; normalize nodelta
3219elim (add_with_carries n a b false) #bits #flags normalize nodelta
3220elim (add_with_carries n (two_complement_negation n a) (two_complement_negation n b) false) #bits' #flags'
3221normalize nodelta #H @H
3222qed.
3223
3224lemma bitvector_opp_addition_n : ∀n. ∀a : BitVector n. addition_n ? a (two_complement_negation ? a) = (zero ?).
3225#n #a lapply (bitvector_opp_direct ? a)
3226>twocomp_neg_direct_ok <addition_n_direct_ok
3227whd in match (addition_n ???);
3228elim (add_with_carries n a (two_complement_negation n a) false) #bits #flags #H @H
3229qed.
3230
3231lemma neutral_addition_n : ∀n. ∀a : BitVector n. addition_n ? a (zero ?) = a.
3232#n #a
3233lapply (neutral_addition_n_direct n a)
3234<addition_n_direct_ok
3235whd in match (addition_n ???);
3236elim (add_with_carries n a (zero n) false) #bits #flags #H @H
3237qed.
3238   
3239lemma subtraction_delta : ∀x,y,delta.
3240  subtraction offset_size
3241    (addition_n offset_size x delta)
3242    (addition_n offset_size y delta) =
3243  subtraction offset_size x y.
3244#x #y #delta whd in match subtraction; normalize nodelta
3245(* Remove all the equal parts on each side of the equation. *)
3246<associative_addition_n
3247>two_complement_negation_plus
3248<(commutative_addition_n … (two_complement_negation ? delta))
3249>(associative_addition_n ? delta) >bitvector_opp_addition_n
3250>(commutative_addition_n ? (zero ?)) >neutral_addition_n
3251@refl
3252qed.
3253
3254(* Offset subtraction is invariant by translation *)
3255lemma sub_offset_translation :
3256 ∀n,x,y,delta. sub_offset n x y = sub_offset n (offset_plus x delta) (offset_plus y delta).
3257#n #x #y #delta
3258whd in match (sub_offset ???) in ⊢ (??%%);
3259elim x #x' elim y #y' elim delta #delta'
3260whd in match (offset_plus ??);
3261whd in match (offset_plus ??);
3262>subtraction_delta @refl
3263qed.
3264
3265(* value_eq lifts to addition *)
3266lemma sub_value_eq :
3267  ∀E,v1,v2,v1',v2',ty1,ty2.
3268   value_eq E v1 v2 →
3269   value_eq E v1' v2' →
3270   ∀r1. (sem_sub v1 ty1 v1' ty2=Some val r1→
3271           ∃r2:val.sem_sub v2 ty1 v2' ty2=Some val r2∧value_eq E r1 r2).
3272#E #v1 #v2 #v1' #v2' #ty1 #ty2 #Hvalue_eq1 #Hvalue_eq2 #r1
3273@(value_eq_inversion E … Hvalue_eq1)
3274[ 1: #v | 2: #sz #i | 3: #f | 4: | 5: #p1 #p2 #Hembed ]
3275[ 1: whd in match (sem_sub ????); normalize nodelta
3276     cases (classify_sub ty1 ty2) normalize nodelta
3277     [ 1: #sz #sg | 2: #fsz | 3: #n #ty #sz #sg | 4: #n #sz #sg #ty | 5: #ty1' #ty2' ]
3278     #Habsurd destruct (Habsurd)
3279| 2: whd in match (sem_sub ????); whd in match (sem_sub ????); normalize nodelta
3280     cases (classify_sub ty1 ty2) normalize nodelta     
3281     [ 1: #tsz #tsg | 2: #tfsz | 3: #tn #ty #tsz #tsg | 4: #tn #tsz #tsg #ty | 5: #ty1' #ty2' ]
3282     [ 2,3,5: #Habsurd destruct (Habsurd) ]
3283     @(value_eq_inversion E … Hvalue_eq2) normalize nodelta
3284     [ 1,6: #v' | 2,7: #sz' #i' | 3,8: #f' | 4,9: | 5,10: #p1' #p2' #Hembed' ]
3285     [ 1,2,4,5,6,7,8,9,10: #Habsurd destruct (Habsurd) ]
3286     @intsize_eq_elim_elim
3287      [ 1: #_ #Habsurd destruct (Habsurd)
3288      | 2: #Heq destruct (Heq) normalize nodelta
3289           #Heq destruct (Heq)
3290          /3 by ex_intro, conj, vint_eq/           
3291      ]
3292| 3: whd in match (sem_sub ????); whd in match (sem_sub ????); normalize nodelta
3293     cases (classify_sub ty1 ty2) normalize nodelta     
3294     [ 1: #tsz #tsg | 2: #tfsz | 3: #tn #ty #tsz #tsg | 4: #tn #tsz #tsg #ty | 5: #ty1' #ty2' ]
3295     [ 1,3,4,5: #Habsurd destruct (Habsurd) ]
3296     @(value_eq_inversion E … Hvalue_eq2) normalize nodelta
3297     [ 1: #v' | 2: #sz' #i' | 3: #f' | 4: | 5: #p1' #p2' #Hembed' ]
3298     [ 1,2,4,5: #Habsurd destruct (Habsurd) ]
3299     #Heq destruct (Heq)
3300     /3 by ex_intro, conj, vfloat_eq/
3301| 4: whd in match (sem_sub ????); whd in match (sem_sub ????); normalize nodelta
3302     cases (classify_sub ty1 ty2) normalize nodelta
3303     [ 1: #tsz #tsg | 2: #tfsz | 3: #tn #ty #tsz #tsg | 4: #tn #tsz #tsg #ty | 5: #ty1' #ty2' ]
3304     [ 1,2,5: #Habsurd destruct (Habsurd) ]
3305     @(value_eq_inversion E … Hvalue_eq2) normalize nodelta
3306     [ 1,6: #v' | 2,7: #sz' #i' | 3,8: #f' | 4,9: | 5,10: #p1' #p2' #Hembed' ]
3307     [ 1,2,4,5,6,7,9,10: #Habsurd destruct (Habsurd) ]         
3308     [ 1: @eq_bv_elim [ 1: normalize nodelta #Heq1 #Heq2 destruct /3 by ex_intro, conj, vnull_eq/
3309                      | 2: #_ normalize nodelta #Habsurd destruct (Habsurd) ]
3310     | 2: #Heq destruct (Heq) /3 by ex_intro, conj, vnull_eq/ ]
3311| 5: whd in match (sem_sub ????); whd in match (sem_sub ????); normalize nodelta
3312     cases (classify_sub ty1 ty2) normalize nodelta
3313     [ 1: #tsz #tsg | 2: #tfsz | 3: #tn #ty #tsz #tsg | 4: #tn #tsz #tsg #ty | 5: #ty1' #ty2' ]
3314     [ 1,2,5: #Habsurd destruct (Habsurd) ]
3315     @(value_eq_inversion E … Hvalue_eq2) normalize nodelta
3316     [ 1,6: #v' | 2,7: #sz' #i' | 3,8: #f' | 4,9: | 5,10: #p1' #p2' #Hembed' ]
3317     [ 1,2,4,5,6,7,8,9: #Habsurd destruct (Habsurd) ]
3318     #Heq destruct (Heq)
3319     [ 1: %{(Vptr (neg_shift_pointer_n (bitsize_of_intsize sz') p2 (sizeof ty) i'))} @conj try @refl
3320          @vptr_eq whd in match (pointer_translation ??) in Hembed ⊢ %;
3321          elim p1 in Hembed; #b1 #o1 normalize nodelta
3322          cases (E b1)
3323          [ 1: normalize in ⊢ (% → ?); #Habsurd destruct (Habsurd)
3324          | 2: * #block #offset normalize nodelta #Heq destruct (Heq)
3325               whd in match (offset_plus ??) in ⊢ (??%%);
3326               whd in match (neg_shift_pointer_n ????) in ⊢ (??%%);
3327               whd in match (neg_shift_offset_n ????) in ⊢ (??%%);
3328               whd in match (subtraction) in ⊢ (??%%); normalize nodelta
3329               generalize in match (short_multiplication ???); #mult
3330               /3 by associative_addition_n, commutative_addition_n, refl/
3331          ]
3332     | 2: lapply Heq @eq_block_elim
3333          [ 2: #_ normalize nodelta #Habsurd destruct (Habsurd)
3334          | 1: #Hpblock1_eq normalize nodelta
3335               elim p1 in Hpblock1_eq Hembed Hembed'; #b1 #off1
3336               elim p1' #b1' #off1' whd in ⊢ (% → % → ?); #Hpblock1_eq destruct (Hpblock1_eq)
3337               whd in ⊢ ((??%?) → (??%?) → ?);
3338               cases (E b1') normalize nodelta
3339               [ 1: #Habsurd destruct (Habsurd) ]
3340               * #dest_block #dest_off normalize nodelta
3341               #Heq_ptr1 #Heq_ptr2 destruct >eq_block_identity normalize nodelta
3342               cases (eqb (sizeof tsg) O) normalize nodelta
3343               [ 1: #Habsurd destruct (Habsurd)
3344               | 2: >(sub_offset_translation 32 off1 off1' dest_off)
3345                    cases (division_u 31
3346                            (sub_offset 32 (offset_plus off1 dest_off) (offset_plus off1' dest_off))
3347                            (repr (sizeof tsg)))
3348                    [ 1: normalize nodelta #Habsurd destruct (Habsurd)
3349                    | 2: #r1' normalize nodelta #Heq2 destruct (Heq2)
3350                         /3 by ex_intro, conj, vint_eq/ ]
3351    ] ] ]
3352] qed.
3353
3354
3355lemma mul_value_eq :
3356  ∀E,v1,v2,v1',v2',ty1,ty2.
3357   value_eq E v1 v2 →
3358   value_eq E v1' v2' →
3359   ∀r1. (sem_mul v1 ty1 v1' ty2=Some val r1→
3360           ∃r2:val.sem_mul v2 ty1 v2' ty2=Some val r2∧value_eq E r1 r2).
3361#E #v1 #v2 #v1' #v2' #ty1 #ty2 #Hvalue_eq1 #Hvalue_eq2 #r1
3362@(value_eq_inversion E … Hvalue_eq1)
3363[ 1: #v | 2: #sz #i | 3: #f | 4: | 5: #p1 #p2 #Hembed ]
3364[ 1: whd in match (sem_mul ????); normalize nodelta
3365     cases (classify_aop ty1 ty2) normalize nodelta
3366     [ 1: #sz #sg | 2: #fsz | 3: #ty1' #ty2' ]
3367     #Habsurd destruct (Habsurd)
3368| 2: whd in match (sem_mul ????); whd in match (sem_mul ????); normalize nodelta
3369     cases (classify_aop ty1 ty2) normalize nodelta
3370     [ 1: #sz #sg | 2: #fsz | 3: #ty1' #ty2' ]
3371     [ 2,3: #Habsurd destruct (Habsurd) ]
3372     @(value_eq_inversion E … Hvalue_eq2) normalize nodelta
3373     [ 1: #v' | 2: #sz' #i' | 3: #f' | 4: | 5: #p1' #p2' #Hembed' ]
3374     [ 1,3,4,5: #Habsurd destruct (Habsurd) ]
3375     @intsize_eq_elim_elim
3376      [ 1: #_ #Habsurd destruct (Habsurd)
3377      | 2: #Heq destruct (Heq) normalize nodelta
3378           #Heq destruct (Heq)
3379          /3 by ex_intro, conj, vint_eq/           
3380      ]
3381| 3: whd in match (sem_mul ????); whd in match (sem_mul ????); normalize nodelta
3382     cases (classify_aop ty1 ty2) normalize nodelta
3383     [ 1: #sz #sg | 2: #fsz | 3: #ty1' #ty2' ]
3384     [ 1,3: #Habsurd destruct (Habsurd) ]
3385     @(value_eq_inversion E … Hvalue_eq2) normalize nodelta     
3386     [ 1: #v' | 2: #sz' #i' | 3: #f' | 4: | 5: #p1' #p2' #Hembed' ]
3387     [ 1,2,4,5: #Habsurd destruct (Habsurd) ]
3388     #Heq destruct (Heq)
3389     /3 by ex_intro, conj, vfloat_eq/
3390| 4: whd in match (sem_mul ????); whd in match (sem_mul ????); normalize nodelta
3391     cases (classify_aop ty1 ty2) normalize nodelta
3392     [ 1: #sz #sg | 2: #fsz | 3: #ty1' #ty2' ]
3393     #Habsurd destruct (Habsurd)
3394| 5: whd in match (sem_mul ????); whd in match (sem_mul ????); normalize nodelta
3395     cases (classify_aop ty1 ty2) normalize nodelta
3396     [ 1: #sz #sg | 2: #fsz | 3: #ty1' #ty2' ]     
3397     #Habsurd destruct (Habsurd)
3398] qed.
3399
3400lemma div_value_eq :
3401  ∀E,v1,v2,v1',v2',ty1,ty2.
3402   value_eq E v1 v2 →
3403   value_eq E v1' v2' →
3404   ∀r1. (sem_div v1 ty1 v1' ty2=Some val r1→
3405           ∃r2:val.sem_div v2 ty1 v2' ty2=Some val r2∧value_eq E r1 r2).
3406#E #v1 #v2 #v1' #v2' #ty1 #ty2 #Hvalue_eq1 #Hvalue_eq2 #r1
3407@(value_eq_inversion E … Hvalue_eq1)
3408[ 1: #v | 2: #sz #i | 3: #f | 4: | 5: #p1 #p2 #Hembed ]
3409[ 1: whd in match (sem_div ????); normalize nodelta
3410     cases (classify_aop ty1 ty2) normalize nodelta
3411     [ 1: #sz #sg | 2: #fsz | 3: #ty1' #ty2' ]
3412     #Habsurd destruct (Habsurd)
3413| 2: whd in match (sem_div ????); whd in match (sem_div ????); normalize nodelta
3414     cases (classify_aop ty1 ty2) normalize nodelta
3415     [ 1: #sz #sg | 2: #fsz | 3: #ty1' #ty2' ]
3416     [ 2,3: #Habsurd destruct (Habsurd) ]
3417     @(value_eq_inversion E … Hvalue_eq2) normalize nodelta
3418     [ 1: #v' | 2: #sz' #i' | 3: #f' | 4: | 5: #p1' #p2' #Hembed' ]
3419     [ 1,3,4,5: #Habsurd destruct (Habsurd) ]
3420     elim sg normalize nodelta
3421     @intsize_eq_elim_elim
3422     [ 1,3: #_ #Habsurd destruct (Habsurd)
3423     | 2,4: #Heq destruct (Heq) normalize nodelta
3424            @(match (division_s (bitsize_of_intsize sz') i i') with
3425              [ None ⇒ ?
3426              | Some bv' ⇒ ? ])
3427            [ 1: normalize  #Habsurd destruct (Habsurd)
3428            | 2: normalize #Heq destruct (Heq)
3429                 /3 by ex_intro, conj, vint_eq/
3430            | 3,4: elim sz' in i' i; #i' #i
3431                   normalize in match (pred_size_intsize ?);
3432                   generalize in match division_u; #division_u normalize
3433                   @(match (division_u ???) with
3434                    [ None ⇒ ?
3435                    | Some bv ⇒ ?]) normalize nodelta
3436                   #H destruct (H)
3437                  /3 by ex_intro, conj, vint_eq/ ]
3438     ]
3439| 3: whd in match (sem_div ????); whd in match (sem_div ????); normalize nodelta
3440     cases (classify_aop ty1 ty2) normalize nodelta
3441     [ 1: #sz #sg | 2: #fsz | 3: #ty1' #ty2' ]
3442     [ 1,3: #Habsurd destruct (Habsurd) ]
3443     @(value_eq_inversion E … Hvalue_eq2) normalize nodelta     
3444     [ 1: #v' | 2: #sz' #i' | 3: #f' | 4: | 5: #p1' #p2' #Hembed' ]
3445     [ 1,2,4,5: #Habsurd destruct (Habsurd) ]
3446     #Heq destruct (Heq)
3447     /3 by ex_intro, conj, vfloat_eq/
3448| 4: whd in match (sem_div ????); whd in match (sem_div ????); normalize nodelta
3449     cases (classify_aop ty1 ty2) normalize nodelta
3450     [ 1: #sz #sg | 2: #fsz | 3: #ty1' #ty2' ]
3451     #Habsurd destruct (Habsurd)
3452| 5: whd in match (sem_div ????); whd in match (sem_div ????); normalize nodelta
3453     cases (classify_aop ty1 ty2) normalize nodelta
3454     [ 1: #sz #sg | 2: #fsz | 3: #ty1' #ty2' ]     
3455     #Habsurd destruct (Habsurd)
3456] qed.
3457
3458lemma mod_value_eq :
3459  ∀E,v1,v2,v1',v2',ty1,ty2.
3460   value_eq E v1 v2 →
3461   value_eq E v1' v2' →
3462   ∀r1. (sem_mod v1 ty1 v1' ty2=Some val r1→
3463           ∃r2:val.sem_mod v2 ty1 v2' ty2=Some val r2∧value_eq E r1 r2).
3464#E #v1 #v2 #v1' #v2' #ty1 #ty2 #Hvalue_eq1 #Hvalue_eq2 #r1
3465@(value_eq_inversion E … Hvalue_eq1)
3466[ 1: #v | 2: #sz #i | 3: #f | 4: | 5: #p1 #p2 #Hembed ]
3467[ 1: whd in match (sem_mod ????); normalize nodelta
3468     cases (classify_aop ty1 ty2) normalize nodelta
3469     [ 1: #sz #sg | 2: #fsz | 3: #ty1' #ty2' ]
3470     #Habsurd destruct (Habsurd)
3471| 2: whd in match (sem_mod ????); whd in match (sem_mod ????); normalize nodelta
3472     cases (classify_aop ty1 ty2) normalize nodelta
3473     [ 1: #sz #sg | 2: #fsz | 3: #ty1' #ty2' ]
3474     [ 2,3: #Habsurd destruct (Habsurd) ]
3475     @(value_eq_inversion E … Hvalue_eq2) normalize nodelta
3476     [ 1: #v' | 2: #sz' #i' | 3: #f' | 4: | 5: #p1' #p2' #Hembed' ]
3477     [ 1,3,4,5: #Habsurd destruct (Habsurd) ]
3478     elim sg normalize nodelta
3479     @intsize_eq_elim_elim
3480     [ 1,3: #_ #Habsurd destruct (Habsurd)
3481     | 2,4: #Heq destruct (Heq) normalize nodelta
3482            @(match (modulus_s (bitsize_of_intsize sz') i i') with
3483              [ None ⇒ ?
3484              | Some bv' ⇒ ? ])
3485            [ 1: normalize  #Habsurd destruct (Habsurd)
3486            | 2: normalize #Heq destruct (Heq)
3487                 /3 by ex_intro, conj, vint_eq/
3488            | 3,4: elim sz' in i' i; #i' #i
3489                   generalize in match modulus_u; #modulus_u normalize
3490                   @(match (modulus_u ???) with
3491                    [ None ⇒ ?
3492                    | Some bv ⇒ ?]) normalize nodelta
3493                   #H destruct (H)
3494                  /3 by ex_intro, conj, vint_eq/ ]
3495     ]
3496| 3: whd in match (sem_mod ????); whd in match (sem_mod ????); normalize nodelta
3497     cases (classify_aop ty1 ty2) normalize nodelta
3498     [ 1: #sz #sg | 2: #fsz | 3: #ty1' #ty2' ]
3499     #Habsurd destruct (Habsurd)
3500| 4: whd in match (sem_mod ????); whd in match (sem_mod ????); normalize nodelta
3501     cases (classify_aop ty1 ty2) normalize nodelta
3502     [ 1: #sz #sg | 2: #fsz | 3: #ty1' #ty2' ]
3503     #Habsurd destruct (Habsurd)
3504| 5: whd in match (sem_mod ????); whd in match (sem_mod ????); normalize nodelta
3505     cases (classify_aop ty1 ty2) normalize nodelta
3506     [ 1: #sz #sg | 2: #fsz | 3: #ty1' #ty2' ]     
3507     #Habsurd destruct (Habsurd)
3508] qed.
3509
3510(* boolean ops *)
3511lemma and_value_eq :
3512  ∀E,v1,v2,v1',v2'.
3513   value_eq E v1 v2 →
3514   value_eq E v1' v2' →
3515   ∀r1. (sem_and v1 v1'=Some val r1→
3516           ∃r2:val.sem_and v2 v2'=Some val r2∧value_eq E r1 r2).
3517#E #v1 #v2 #v1' #v2' #Hvalue_eq1 #Hvalue_eq2 #r1
3518@(value_eq_inversion E … Hvalue_eq1)
3519[ 2: #sz #i
3520     @(value_eq_inversion E … Hvalue_eq2)
3521     [ 2: #sz' #i' whd in match (sem_and ??);
3522          @intsize_eq_elim_elim
3523          [ 1: #_ #Habsurd destruct (Habsurd)
3524          | 2: #Heq destruct (Heq) normalize nodelta
3525               #Heq destruct (Heq) /3 by ex_intro,conj,vint_eq/ ]
3526] ]
3527normalize in match (sem_and ??); #arg1 destruct
3528normalize in match (sem_and ??); #arg2 destruct
3529normalize in match (sem_and ??); #arg3 destruct
3530normalize in match (sem_and ??); #arg4 destruct
3531qed.
3532
3533lemma or_value_eq :
3534  ∀E,v1,v2,v1',v2'.
3535   value_eq E v1 v2 →
3536   value_eq E v1' v2' →
3537   ∀r1. (sem_or v1 v1'=Some val r1→
3538           ∃r2:val.sem_or v2 v2'=Some val r2∧value_eq E r1 r2).
3539#E #v1 #v2 #v1' #v2' #Hvalue_eq1 #Hvalue_eq2 #r1
3540@(value_eq_inversion E … Hvalue_eq1)
3541[ 2: #sz #i
3542     @(value_eq_inversion E … Hvalue_eq2)
3543     [ 2: #sz' #i' whd in match (sem_or ??);
3544          @intsize_eq_elim_elim
3545          [ 1: #_ #Habsurd destruct (Habsurd)
3546          | 2: #Heq destruct (Heq) normalize nodelta
3547               #Heq destruct (Heq) /3 by ex_intro,conj,vint_eq/ ]
3548] ]
3549normalize in match (sem_or ??); #arg1 destruct
3550normalize in match (sem_or ??); #arg2 destruct
3551normalize in match (sem_or ??); #arg3 destruct
3552normalize in match (sem_or ??); #arg4 destruct
3553qed.
3554
3555lemma xor_value_eq :
3556  ∀E,v1,v2,v1',v2'.
3557   value_eq E v1 v2 →
3558   value_eq E v1' v2' →
3559   ∀r1. (sem_xor v1 v1'=Some val r1→
3560           ∃r2:val.sem_xor v2 v2'=Some val r2∧value_eq E r1 r2).
3561#E #v1 #v2 #v1' #v2' #Hvalue_eq1 #Hvalue_eq2 #r1
3562@(value_eq_inversion E … Hvalue_eq1)
3563[ 2: #sz #i
3564     @(value_eq_inversion E … Hvalue_eq2)
3565     [ 2: #sz' #i' whd in match (sem_xor ??);
3566          @intsize_eq_elim_elim
3567          [ 1: #_ #Habsurd destruct (Habsurd)
3568          | 2: #Heq destruct (Heq) normalize nodelta
3569               #Heq destruct (Heq) /3 by ex_intro,conj,vint_eq/ ]
3570] ]
3571normalize in match (sem_xor ??); #arg1 destruct
3572normalize in match (sem_xor ??); #arg2 destruct
3573normalize in match (sem_xor ??); #arg3 destruct
3574normalize in match (sem_xor ??); #arg4 destruct
3575qed.
3576
3577lemma shl_value_eq :
3578  ∀E,v1,v2,v1',v2'.
3579   value_eq E v1 v2 →
3580   value_eq E v1' v2' →
3581   ∀r1. (sem_shl v1 v1'=Some val r1→
3582           ∃r2:val.sem_shl v2 v2'=Some val r2∧value_eq E r1 r2).
3583#E #v1 #v2 #v1' #v2' #Hvalue_eq1 #Hvalue_eq2 #r1
3584@(value_eq_inversion E … Hvalue_eq1)
3585[ 1: #v | 2: #sz #i | 3: #f | 4: | 5: #p1 #p2 #Hembed ]
3586[ 2:
3587     @(value_eq_inversion E … Hvalue_eq2)
3588     [ 1: #v' | 2: #sz' #i' | 3: #f' | 4: | 5: #p1' #p2' #Hembed' ]
3589     [ 2: whd in match (sem_shl ??);
3590          cases (lt_u ???) normalize nodelta
3591          [ 1: #Heq destruct (Heq) /3 by ex_intro,conj,vint_eq/
3592          | 2: #Habsurd destruct (Habsurd)
3593          ]
3594     | *: whd in match (sem_shl ??); #Habsurd destruct (Habsurd) ]
3595| *: whd in match (sem_shl ??); #Habsurd destruct (Habsurd) ]
3596qed.
3597
3598lemma shr_value_eq :
3599  ∀E,v1,v2,v1',v2',ty,ty'.
3600   value_eq E v1 v2 →
3601   value_eq E v1' v2' →
3602   ∀r1. (sem_shr v1 ty v1' ty'=Some val r1→
3603           ∃r2:val.sem_shr v2 ty v2' ty'=Some val r2∧value_eq E r1 r2).
3604#E #v1 #v2 #v1' #v2' #ty #ty' #Hvalue_eq1 #Hvalue_eq2 #r1
3605@(value_eq_inversion E … Hvalue_eq1)
3606[ 1: #v | 2: #sz #i | 3: #f | 4: | 5: #p1 #p2 #Hembed ]
3607whd in match (sem_shr ????); whd in match (sem_shr ????);
3608[ 1: cases (classify_aop ty ty') normalize nodelta
3609     [ 1: #sz #sg | 2: #fsz | 3: #ty1' #ty2' ]
3610     #Habsurd destruct (Habsurd)
3611| 2: cases (classify_aop ty ty') normalize nodelta
3612     [ 1: #sz #sg | 2: #fsz | 3: #ty1' #ty2' ]
3613     [ 2,3: #Habsurd destruct (Habsurd) ]
3614     @(value_eq_inversion E … Hvalue_eq2) normalize nodelta
3615     [ 1: #v' | 2: #sz' #i' | 3: #f' | 4: | 5: #p1' #p2' #Hembed' ]
3616     [ 1,3,4,5: #Habsurd destruct (Habsurd) ]
3617     elim sg normalize nodelta
3618     cases (lt_u ???) normalize nodelta #Heq destruct (Heq)
3619     /3 by ex_intro, conj, refl, vint_eq/
3620| 3: cases (classify_aop ty ty') normalize nodelta
3621     [ 1: #sz #sg | 2: #fsz | 3: #ty1' #ty2' ]
3622     #Habsurd destruct (Habsurd)
3623| 4: cases (classify_aop ty ty') normalize nodelta
3624     [ 1: #sz #sg | 2: #fsz | 3: #ty1' #ty2' ]
3625     #Habsurd destruct (Habsurd)
3626| 5: cases (classify_aop ty ty') normalize nodelta
3627     [ 1: #sz #sg | 2: #fsz | 3: #ty1' #ty2' ]
3628     #Habsurd destruct (Habsurd)
3629] qed.
3630
3631lemma monotonic_Zlt_Zsucc: monotonic Z Zlt Zsucc.
3632whd #x #y #Hlt lapply (Zlt_to_Zle … Hlt) #Hle lapply (Zle_to_Zlt … Hle)
3633/3 by monotonic_Zle_Zplus_r, Zle_to_Zlt/ qed.
3634
3635lemma monotonic_Zlt_Zpred: monotonic Z Zlt Zpred.
3636whd #x #y #Hlt lapply (Zlt_to_Zle … Hlt) #Hle lapply (Zle_to_Zlt … Hle)
3637/3 by monotonic_Zle_Zpred, Zle_to_Zlt/ qed.
3638
3639lemma antimonotonic_Zle_Zsucc: ∀x,y. Zsucc x ≤ Zsucc y → x ≤ y.
3640#x #y #H lapply (monotonic_Zle_Zpred … H) >Zpred_Zsucc >Zpred_Zsucc #H @H
3641qed.
3642
3643(*
3644lemma antimonotonic_Zle_Zpred: ∀x,y. Zpred x ≤ Zpred y → x ≤ y.
3645#x #y #H lapply (monotonic_Zle_Zsucc … H) >Zsucc_Zpred >Zsucc_Zpred #H @H
3646qed. *)
3647
3648lemma antimonotonic_Zlt_Zsucc: ∀x,y. Zsucc x < Zsucc y → x < y.
3649#x #y #Hlt lapply (Zle_to_Zlt … (antimonotonic_Zle_Zsucc … (Zlt_to_Zle … Hlt)))
3650>Zpred_Zsucc #H @H
3651qed.
3652
3653lemma antimonotonic_Zlt_Zpred: ∀x,y. Zpred x < Zpred y → x < y.
3654#x #y #Hlt lapply (monotonic_Zlt_Zsucc … Hlt) >Zsucc_Zpred >Zsucc_Zpred #H @H
3655qed.
3656
3657lemma not_Zlt_to_Zltb_false : ∀n,m. n ≮ m → Zltb n m = false.
3658#n #m #Hnlt
3659@Zltb_elim_Type0
3660[ 1: elim Hnlt #H0 #H1 @(False_ind … (H0 H1))
3661| 2: #_ @refl ] qed.
3662
3663lemma Zplus_eq_eq : ∀x,y,delta:Z. eqZb x y = eqZb (x + delta) (y + delta).
3664#x #y #delta
3665@eqZb_elim
3666[ 1: #Heq >Heq >eqZb_z_z @refl
3667| 2: * #Hneq cut (x+delta ≠ y + delta)
3668     [ 1: % #H cut (x = y) [ 1: @(injective_Zplus_l delta) @H ] #H' @Hneq @H' ]
3669     #H @sym_eq @eqZb_false @H ] qed.
3670     
3671lemma Zltb_Zsucc : ∀x,y. Zltb x y = Zltb (Zsucc x) (Zsucc y).
3672#x #y
3673@(Zltb_elim_Type0 … x y)
3674[ 1: #Hlt @sym_eq lapply (monotonic_Zlt_Zsucc … Hlt) #Hlt' @(Zlt_to_Zltb_true … Hlt')
3675| 2: #Hnlt @sym_eq @not_Zlt_to_Zltb_false % #Hltsucc
3676      lapply (antimonotonic_Zlt_Zsucc … Hltsucc) #Hlt
3677      @(absurd … Hlt Hnlt)
3678] qed.
3679
3680lemma Zltb_Zpred : ∀x,y. Zltb x y = Zltb (Zpred x) (Zpred y).
3681#x #y
3682@(Zltb_elim_Type0 … x y)
3683[ 1: #Hlt @sym_eq
3684lapply (monotonic_Zlt_Zpred … Hlt) #Hlt' @(Zlt_to_Zltb_true … Hlt')
3685| 2: #Hnlt @sym_eq @not_Zlt_to_Zltb_false % #Hltsucc
3686      lapply (antimonotonic_Zlt_Zpred … Hltsucc) #Hlt
3687      @(absurd … Hlt Hnlt)
3688] qed.           
3689
3690lemma Zplus_pos_lt_lt : ∀x,y.∀delta. Zltb x y = Zltb (x + (pos delta)) (y + (pos delta)).
3691#x #y #delta @(pos_elim … delta)
3692[ 1: >(sym_Zplus x) >(sym_Zplus y) <Zsucc_Zplus_pos_O <Zsucc_Zplus_pos_O
3693     >Zltb_Zsucc @refl
3694| 2: #n #Hind >Hind >Zltb_Zsucc
3695     >(sym_Zplus x) >(sym_Zplus y)
3696     <Zplus_Zsucc <Zplus_Zsucc
3697     >(sym_Zplus ? x) >(sym_Zplus ? y)
3698     normalize in match (Zsucc ?); @refl
3699] qed.
3700
3701lemma Zplus_neg_lt_lt : ∀x,y.∀delta. Zltb x y = Zltb (x + (neg delta)) (y + (neg delta)).
3702#x #y #delta @(pos_elim … delta)
3703[ 1: >(sym_Zplus x) >(sym_Zplus y) <Zpred_Zplus_neg_O <Zpred_Zplus_neg_O
3704     >Zltb_Zpred @refl
3705| 2: #n #Hind >Hind >Zltb_Zpred
3706     >(sym_Zplus x) >(sym_Zplus y)
3707     <Zplus_Zpred <Zplus_Zpred
3708     >(sym_Zplus ? x) >(sym_Zplus ? y)
3709     normalize in match (Zpred ?); @refl
3710] qed.
3711
3712(* I would not be surprised for a simpler proof that mine to exist. *)
3713lemma Zplus_lt_lt : ∀x,y,delta:Z. Zltb x y = Zltb (x + delta) (y + delta).
3714#x #y #delta
3715cases delta
3716[ 1: >Zplus_z_OZ >Zplus_z_OZ @refl
3717| 2: #p @Zplus_pos_lt_lt
3718| 3: #p @Zplus_neg_lt_lt
3719] qed.
3720
3721(* offset equality is invariant by translation *)
3722lemma eq_offset_translation : ∀delta,x,y. cmp_offset Ceq (offset_plus x delta) (offset_plus y delta) = cmp_offset Ceq x y.
3723#delta #x #y normalize
3724elim delta #zdelta @sym_eq @cthulhu qed. (* @Zplus_eq_eq qed.*)
3725
3726lemma neq_offset_translation : ∀delta,x,y. cmp_offset Cne (offset_plus x delta) (offset_plus y delta) = cmp_offset Cne x y.
3727@cthulhu qed.
3728(* #delta #x #y normalize
3729elim delta #zdelta @sym_eq <Zplus_eq_eq qed. *)
3730
3731lemma cmp_offset_translation : ∀op,delta,x,y.
3732   cmp_offset op x y = cmp_offset op (offset_plus x delta) (offset_plus y delta). @cthulhu qed.
3733(*
3734* #delta #x #y normalize
3735elim delta #zdelta
3736[ 1: @Zplus_eq_eq
3737| 2: <Zplus_eq_eq @refl
3738| 3: @Zplus_lt_lt
3739| 4: <Zplus_lt_lt @refl
3740| 5: @Zplus_lt_lt
3741| 6: <Zplus_lt_lt @refl
3742qed. *)
3743
3744lemma cmp_value_eq :
3745  ∀E,v1,v2,v1',v2',ty,ty',m1,m2.
3746   value_eq E v1 v2 →
3747   value_eq E v1' v2' →
3748   memory_inj E m1 m2 →   
3749   ∀op,r1. (sem_cmp op v1 ty v1' ty' m1 = Some val r1→
3750           ∃r2:val.sem_cmp op v2 ty v2' ty' m2 = Some val r2∧value_eq E r1 r2).
3751#E #v1 #v2 #v1' #v2' #ty #ty' #m1 #m2 #Hvalue_eq1 #Hvalue_eq2 #Hinj #op #r1
3752elim m1 in Hinj; #contmap1 #nextblock1 #Hnextblock1 elim m2 #contmap2 #nextblock2 #Hnextblock2 #Hinj
3753whd in match (sem_cmp ??????) in ⊢ ((??%?) → %);
3754cases (classify_cmp ty ty') normalize nodelta
3755[ 1: #tsz #tsg
3756     @(value_eq_inversion E … Hvalue_eq1) normalize nodelta
3757     [ 1: #v #Habsurd destruct (Habsurd)
3758     | 3: #f #Habsurd destruct (Habsurd)
3759     | 4: #Habsurd destruct (Habsurd)
3760     | 5: #p1 #p2 #Hembed #Habsurd destruct (Habsurd) ]
3761     #sz #i
3762     @(value_eq_inversion E … Hvalue_eq2) normalize nodelta
3763     [ 1: #v #Habsurd destruct (Habsurd)
3764     | 3: #f #Habsurd destruct (Habsurd)
3765     | 4: #Habsurd destruct (Habsurd)
3766     | 5: #p1 #p2 #Hembed #Habsurd destruct (Habsurd) ]
3767     #sz' #i' cases tsg normalize nodelta
3768     @intsize_eq_elim_elim
3769     [ 1,3: #Hneq #Habsurd destruct (Habsurd)
3770     | 2,4: #Heq destruct (Heq) normalize nodelta
3771            #Heq destruct (Heq)     
3772            [ 1: cases (cmp_int ????) whd in match (of_bool ?);
3773            | 2: cases (cmpu_int ????) whd in match (of_bool ?); ]
3774              /3 by ex_intro, conj, vint_eq/ ]
3775| 3: #fsz
3776     @(value_eq_inversion E … Hvalue_eq1) normalize nodelta
3777     [ 1: #v #Habsurd destruct (Habsurd)
3778     | 2: #sz #i #Habsurd destruct (Habsurd)
3779     | 4: #Habsurd destruct (Habsurd)
3780     | 5: #p1 #p2 #Hembed #Habsurd destruct (Habsurd) ]
3781     #f
3782     @(value_eq_inversion E … Hvalue_eq2) normalize nodelta
3783     [ 1: #v #Habsurd destruct (Habsurd)
3784     | 2: #sz #i #Habsurd destruct (Habsurd)
3785     | 4: #Habsurd destruct (Habsurd)
3786     | 5: #p1 #p2 #Hembed #Habsurd destruct (Habsurd) ]
3787     #f'
3788     #Heq destruct (Heq) cases (Fcmp op f f')
3789     /3 by ex_intro, conj, vint_eq/
3790| 4: #ty1 #ty2 #Habsurd destruct (Habsurd)
3791| 2: #optn #typ             
3792     @(value_eq_inversion E … Hvalue_eq1) normalize nodelta
3793     [ 1: #v #Habsurd destruct (Habsurd)
3794     | 2: #sz #i #Habsurd destruct (Habsurd)
3795     | 3: #f #Habsurd destruct (Habsurd)
3796     | 5: #p1 #p2 #Hembed ]
3797     @(value_eq_inversion E … Hvalue_eq2) normalize nodelta
3798     [ 1,6: #v #Habsurd destruct (Habsurd)
3799     | 2,7: #sz #i #Habsurd destruct (Habsurd)
3800     | 3,8: #f #Habsurd destruct (Habsurd)
3801     | 5,10: #p1' #p2' #Hembed' ]
3802     [ 2,3: cases op whd in match (sem_cmp_mismatch ?);
3803          #Heq destruct (Heq)
3804          [ 1,3: %{Vfalse} @conj try @refl @vint_eq
3805          | 2,4: %{Vtrue} @conj try @refl @vint_eq ]
3806     | 4: cases op whd in match (sem_cmp_match ?);
3807          #Heq destruct (Heq)
3808          [ 2,4: %{Vfalse} @conj try @refl @vint_eq
3809          | 1,3: %{Vtrue} @conj try @refl @vint_eq ] ]
3810     lapply (mi_valid_pointers … Hinj p1' p2')
3811     lapply (mi_valid_pointers … Hinj p1 p2)         
3812     cases (valid_pointer (mk_mem ???) p1')
3813     [ 2: #_ #_ >commutative_andb normalize in ⊢ (% → ?); #Habsurd destruct (Habsurd) ]
3814     cases (valid_pointer (mk_mem ???) p1)
3815     [ 2: #_ #_ normalize in ⊢ (% → ?); #Habsurd destruct (Habsurd) ]
3816     #H1 #H2 lapply (H1 (refl ??) Hembed) #Hvalid1 lapply (H2 (refl ??) Hembed') #Hvalid2
3817     >Hvalid1 >Hvalid2 normalize nodelta -H1 -H2
3818     elim p1 in Hembed; #b1 #o1
3819     elim p1' in Hembed'; #b1' #o1'
3820     whd in match (pointer_translation ??);
3821     whd in match (pointer_translation ??);
3822     @(eq_block_elim … b1 b1')
3823     [ 1: #Heq destruct (Heq)
3824          cases (E b1') normalize nodelta
3825          [ 1: #Habsurd destruct (Habsurd) ]
3826          * #eb1' #eo1' normalize nodelta
3827          #Heq1 #Heq2 #Heq3 destruct
3828          >eq_block_identity normalize nodelta
3829          <cmp_offset_translation
3830          cases (cmp_offset ???) normalize nodelta         
3831          /3 by ex_intro, conj, vint_eq/
3832     | 2: #Hneq lapply (mi_disjoint … Hinj b1 b1')
3833          cases (E b1') [ 1: #_ normalize nodelta #Habsurd destruct (Habsurd) ]
3834          * #eb1 #eo1
3835          cases (E b1) [ 1: #_ normalize nodelta #_ #Habsurd destruct (Habsurd) ]
3836          * #eb1' #eo1' normalize nodelta #H #Heq1 #Heq2 destruct
3837          lapply (H ???? Hneq (refl ??) (refl ??))
3838          #Hneq_block >(neq_block_eq_block_false … Hneq_block) normalize nodelta
3839          elim op whd in match (sem_cmp_mismatch ?); #Heq destruct (Heq)
3840          /3 by ex_intro, conj, vint_eq/
3841     ]
3842] qed.               
3843
3844(* Commutation result for binary operators. *)
3845lemma binary_operation_value_eq :
3846  ∀E,op,v1,v2,v1',v2',ty1,ty2,m1,m2.
3847   value_eq E v1 v2 →
3848   value_eq E v1' v2' →
3849   memory_inj E m1 m2 →
3850   ∀r1.
3851   sem_binary_operation op v1 ty1 v1' ty2 m1 = Some ? r1 →
3852   ∃r2.sem_binary_operation op v2 ty1 v2' ty2 m2 = Some ? r2 ∧ value_eq E r1 r2.
3853#E #op #v1 #v2 #v1' #v2' #ty1 #ty2 #m1 #m2 #Hvalue_eq1 #Hvalue_eq2 #Hinj #r1
3854cases op
3855whd in match (sem_binary_operation ??????);
3856whd in match (sem_binary_operation ??????);
3857[ 1: @add_value_eq try assumption
3858| 2: @sub_value_eq try assumption
3859| 3: @mul_value_eq try assumption
3860| 4: @div_value_eq try assumption
3861| 5: @mod_value_eq try assumption
3862| 6: @and_value_eq try assumption
3863| 7: @or_value_eq try assumption
3864| 8: @xor_value_eq try assumption
3865| 9: @shl_value_eq try assumption
3866| 10: @shr_value_eq try assumption
3867| *: @cmp_value_eq try assumption
3868] qed.
3869
3870lemma cast_value_eq :
3871 ∀E,m1,m2,v1,v2. (* memory_inj E m1 m2 → *) value_eq E v1 v2 →
3872  ∀ty,cast_ty,res. exec_cast m1 v1 ty cast_ty = OK ? res →
3873  ∃res'. exec_cast m2 v2 ty cast_ty = OK ? res' ∧ value_eq E res res'.
3874#E #m1 #m2 #v1 #v2 (* #Hmemory_inj *) #Hvalue_eq #ty #cast_ty #res
3875@(value_eq_inversion … Hvalue_eq)
3876[ 1: #v normalize #Habsurd destruct (Habsurd)
3877| 2: #vsz #vi whd in match (exec_cast ????);
3878     cases ty
3879     [ 1: | 2: #sz #sg | 3: #fl | 4: #ptrty | 5: #arrayty #n | 6: #tl #retty | 7: #id #fl | 8: #id #fl | 9: #comptrty ]
3880     normalize nodelta
3881     [ 1,3,7,8,9: #Habsurd destruct (Habsurd)
3882     | 2: @intsize_eq_elim_elim
3883          [ 1: #Hneq #Habsurd destruct (Habsurd)
3884          | 2: #Heq destruct (Heq) normalize nodelta
3885               cases cast_ty
3886               [ 1: | 2: #csz #csg | 3: #cfl | 4: #cptrty | 5: #carrayty #cn
3887               | 6: #ctl #cretty | 7: #cid #cfl | 8: #cid #cfl | 9: #ccomptrty ]
3888               normalize nodelta
3889               [ 1,7,8,9: #Habsurd destruct (Habsurd)
3890               | 2: #Heq destruct (Heq) /3 by ex_intro, conj, vint_eq/
3891               | 3: #Heq destruct (Heq) /3 by ex_intro, conj, vfloat_eq/
3892               | 4,5,6: whd in match (try_cast_null ?????); normalize nodelta
3893                    @eq_bv_elim
3894                    [ 1,3,5: #Heq destruct (Heq) >eq_intsize_identity normalize nodelta
3895                         whd in match (m_bind ?????);
3896                         #Heq destruct (Heq) /3 by ex_intro, conj, vnull_eq/
3897                    | 2,4,6: #Hneq >eq_intsize_identity normalize nodelta
3898                         whd in match (m_bind ?????);
3899                         #Habsurd destruct (Habsurd) ] ]
3900          ]
3901     | 4,5,6: whd in match (try_cast_null ?????); normalize nodelta
3902          @eq_bv_elim
3903          [ 1,3,5: #Heq destruct (Heq) normalize nodelta
3904               whd in match (m_bind ?????); #Habsurd destruct (Habsurd)
3905          | 2,4,6: #Hneq normalize nodelta
3906               whd in match (m_bind ?????); #Habsurd destruct (Habsurd) ]
3907     ]
3908| 3: #f whd in match (exec_cast ????);
3909     cases ty
3910     [ 1: | 2: #sz #sg | 3: #fl | 4: #ptrty | 5: #arrayty #n
3911     | 6: #tl #retty | 7: #id #fl | 8: #id #fl | 9: #comptrty ]
3912     normalize nodelta
3913     [ 1,2,4,5,6,7,8,9: #Habsurd destruct (Habsurd) ]
3914     cases cast_ty
3915     [ 1: | 2: #csz #csg | 3: #cfl | 4: #cptrty | 5: #carrayty #cn
3916     | 6: #ctl #cretty | 7: #cid #cfl | 8: #cid #cfl | 9: #ccomptrty ]
3917     normalize nodelta
3918     [ 1,4,5,6,7,8,9: #Habsurd destruct (Habsurd) ]
3919     #Heq destruct (Heq)
3920     [ 1: /3 by ex_intro, conj, vint_eq/
3921     | 2: /3 by ex_intro, conj, vfloat_eq/ ]
3922| 4: whd in match (exec_cast ????);
3923     cases ty
3924     [ 1: | 2: #sz #sg | 3: #fl | 4: #ptrty | 5: #arrayty #n
3925     | 6: #tl #retty | 7: #id #fl | 8: #id #fl | 9: #comptrty ]
3926     normalize
3927     [ 1,2,3,7,8,9: #Habsurd destruct (Habsurd) ]
3928     cases cast_ty normalize nodelta
3929     [ 1,10,19: #Habsurd destruct (Habsurd)
3930     | 2,11,20: #csz #csg #Habsurd destruct (Habsurd)
3931     | 3,12,21: #cfl #Habsurd destruct (Habsurd)
3932     | 4,13,22: #cptrty #Heq destruct (Heq) /3 by ex_intro, conj, vnull_eq/
3933     | 5,14,23: #carrayty #cn #Heq destruct (Heq) /3 by ex_intro, conj, vnull_eq/
3934     | 6,15,24: #ctl #cretty #Heq destruct (Heq) /3 by ex_intro, conj, vnull_eq/
3935     | 7,16,25: #cid #cfl #Habsurd destruct (Habsurd)
3936     | 8,17,26: #cid #cfl #Habsurd destruct (Habsurd)
3937     | 9,18,27: #ccomptrty #Habsurd destruct (Habsurd) ]
3938| 5: #p1 #p2 #Hembed whd in match (exec_cast ????);
3939     cases ty
3940     [ 1: | 2: #sz #sg | 3: #fl | 4: #ptrty | 5: #arrayty #n
3941     | 6: #tl #retty | 7: #id #fl | 8: #id #fl | 9: #comptrty ]
3942     normalize
3943     [ 1,2,3,7,8,9: #Habsurd destruct (Habsurd) ]
3944     cases cast_ty normalize nodelta
3945     [ 1,10,19: #Habsurd destruct (Habsurd)
3946     | 2,11,20: #csz #csg #Habsurd destruct (Habsurd)
3947     | 3,12,21: #cfl #Habsurd destruct (Habsurd)
3948     | 4,13,22: #cptrty #Heq destruct (Heq) %{(Vptr p2)} @conj try @refl @vptr_eq assumption
3949     | 5,14,23: #carrayty #cn #Heq destruct (Heq)
3950                %{(Vptr p2)} @conj try @refl @vptr_eq assumption
3951     | 6,15,24: #ctl #cretty #Heq destruct (Heq)
3952                %{(Vptr p2)} @conj try @refl @vptr_eq assumption
3953     | 7,16,25: #cid #cfl #Habsurd destruct (Habsurd)
3954     | 8,17,26: #cid #cfl #Habsurd destruct (Habsurd)
3955     | 9,18,27: #ccomptrty #Habsurd destruct (Habsurd) ]
3956qed.
3957
3958lemma bool_of_val_value_eq :
3959 ∀E,v1,v2. value_eq E v1 v2 →
3960   ∀ty,b.exec_bool_of_val v1 ty = OK ? b → exec_bool_of_val v2 ty = OK ? b.
3961#E #v1 #v2 #Hvalue_eq #ty #b
3962@(value_eq_inversion … Hvalue_eq) //
3963[ 1: #v #H normalize in H; destruct (H)
3964| 2: #p1 #p2 #Hembed #H @H ] qed.
3965 
3966(* Simulation relation on expressions *)
3967lemma sim_related_globals : ∀ge,ge',en1,m1,en2,m2,ext.
3968  ∀E:embedding.
3969  ∀Hext:memory_ext E m1 m2.
3970  switch_removal_globals E ? fundef_switch_removal ge ge' →
3971  disjoint_extension en1 m1 en2 m2 ext E Hext →
3972  ext_fresh_for_genv ext ge →
3973  (∀e. exec_expr_sim E (exec_expr ge en1 m1 e) (exec_expr ge' en2 m2 e)) ∧
3974  (∀ed, ty. exec_lvalue_sim E (exec_lvalue' ge en1 m1 ed ty) (exec_lvalue' ge' en2 m2 ed ty)).
3975#ge #ge' #en1 #m1 #en2 #m2 #ext #E #Hext #Hrelated #Hdisjoint #Hext_fresh_for_genv
3976@expr_lvalue_ind_combined
3977[ 1: #csz #cty #i #a1
3978     whd in match (exec_expr ????); elim cty
3979     [ 1: | 2: #sz #sg | 3: #fl | 4: #ty | 5: #ty #n | 6: #tl #ty | 7: #id #fl | 8: #id #fl | 9: #ty ]
3980     normalize nodelta
3981     [ 2: cases (eq_intsize csz sz) normalize nodelta
3982          [ 1: #H destruct (H) /4 by ex_intro, conj, vint_eq/
3983          | 2: #Habsurd destruct (Habsurd) ]
3984     | 4,5,6: #_ #H destruct (H)
3985     | *: #H destruct (H) ]
3986| 2: #ty #fl #a1
3987     whd in match (exec_expr ????); #H1 destruct (H1) /4 by ex_intro, conj, vint_eq/
3988| 3: *
3989  [ 1: #sz #i | 2: #fl | 3: #var_id | 4: #e1 | 5: #e1 | 6: #op #e1 | 7: #op #e1 #e2 | 8: #cast_ty #e1
3990  | 9: #cond #iftrue #iffalse | 10: #e1 #e2 | 11: #e1 #e2 | 12: #sizeofty | 13: #e1 #field | 14: #cost #e1 ]
3991  #ty whd in ⊢ (% → ?); #Hind try @I
3992  whd in match (Plvalue ???);
3993  [ 1,2,3: whd in match (exec_expr ????); whd in match (exec_expr ????); #a1
3994       cases (exec_lvalue' ge en1 m1 ? ty) in Hind;
3995       [ 2,4,6: #error #_ normalize in ⊢ (% → ?); #Habsurd destruct (Habsurd)
3996       | 1,3,5: #b1 #H elim (H b1 (refl ??)) #b2 *
3997           elim b1 * #bl1 #o1 #tr1 elim b2 * #bl2 #o2 #tr2
3998           #Heq >Heq normalize nodelta * #Hvalue_eq #Htrace_eq
3999           whd in match (load_value_of_type' ???);
4000           whd in match (load_value_of_type' ???);
4001           lapply (load_value_of_type_inj E … (\fst a1) … ty (me_inj … Hext) Hvalue_eq)
4002           cases (load_value_of_type ty m1 bl1 o1)
4003           [ 1,3,5: #_ #Habsurd normalize in Habsurd; destruct (Habsurd)
4004           | 2,4,6: #v #Hyp normalize in ⊢ (% → ?); #Heq destruct (Heq)
4005                    elim (Hyp (refl ??)) #v2 * #Hload #Hvalue_eq >Hload
4006                    normalize /4 by ex_intro, conj/
4007  ] ] ]
4008| 4: #v #ty whd * * #b1 #o1 #tr1
4009     whd in match (exec_lvalue' ?????);
4010     whd in match (exec_lvalue' ?????);
4011     lapply (Hdisjoint v)
4012     lapply (Hext_fresh_for_genv v)
4013     cases (mem_assoc_env v ext) #Hglobal
4014     [ 1: * #vblock * * #Hlookup_en2 #Hwriteable #Hnot_in_en1
4015          >Hnot_in_en1 normalize in Hglobal ⊢ (% → ?);
4016          >(Hglobal (refl ??)) normalize
4017          #Habsurd destruct (Habsurd)
4018     | 2: normalize nodelta
4019          cases (lookup ?? en1 v) normalize nodelta
4020          [ 1: #Hlookup2 >Hlookup2 normalize nodelta
4021               lapply (rg_find_symbol … Hrelated v)
4022               cases (find_symbol ???) normalize
4023               [ 1: #_ #Habsurd destruct (Habsurd)
4024               | 2: #block cases (lookup ?? (symbols clight_fundef ge') v)
4025                    [ 1: normalize nodelta #Hfalse @(False_ind … Hfalse)
4026                    | 2: #block' normalize #Hvalue_eq #Heq destruct (Heq)
4027                         %{〈block',mk_offset (zero offset_size),[]〉} @conj try @refl
4028                         normalize /2/
4029                ] ]
4030         | 2: #block
4031              cases (lookup ?? en2 v) normalize nodelta
4032              [ 1: #Hfalse @(False_ind … Hfalse)
4033              | 2: #b * #Hvalid_block #Hvalue_eq #Heq destruct (Heq)
4034                   %{〈b, zero_offset, E0〉} @conj try @refl
4035                   normalize /2/
4036    ] ] ]
4037| 5: #e #ty whd in ⊢ (% → %);
4038     whd in match (exec_lvalue' ?????);
4039     whd in match (exec_lvalue' ?????);
4040     cases (exec_expr ge en1 m1 e)
4041     [ 1: * #v1 #tr1 #H elim (H 〈v1,tr1〉 (refl ??)) * #v1' #tr1' * #Heq >Heq normalize nodelta
4042          * elim v1 normalize nodelta
4043          [ 1: #_ #_ #a1 #Habsurd destruct (Habsurd)
4044          | 2: #sz #i #_ #_ #a1  #Habsurd destruct (Habsurd)
4045          | 3: #fl #_ #_ #a1 #Habsurd destruct (Habsurd)
4046          | 4: #_ #_ #a1 #Habsurd destruct (Habsurd)
4047          | 5: #ptr #Hvalue_eq lapply (value_eq_ptr_inversion … Hvalue_eq) * #p2 * #Hp2_eq
4048               >Hp2_eq in Hvalue_eq; elim ptr #b1 #o1 elim p2 #b2 #o2
4049               #Hvalue_eq normalize
4050               cases (E b1) [ 1: normalize in ⊢ (% → ?); #Habsurd destruct (Habsurd) ]
4051               * #b2' #o2' normalize #Heq destruct (Heq) #Htrace destruct (Htrace)
4052               * * #b1' #o1' #tr1'' #Heq2 destruct (Heq2) normalize
4053               %{〈b2,mk_offset (addition_n ? (offv o1') (offv o2')),tr1''〉} @conj try @refl
4054               normalize @conj // ]
4055     | 2: #error #_ normalize #a1 #Habsurd destruct (Habsurd) ]
4056| 6: #ty #e #ty'
4057     #Hsim @(exec_lvalue_expr_elim … Hsim)
4058     cases ty
4059     [ 1: | 2: #sz #sg | 3: #fl | 4: #ty | 5: #ty #n | 6: #tl #ty | 7: #id #fl | 8: #id #fl | 9: #ty ]
4060     * #b1 #o1 * #b2 #o2 normalize nodelta try /2 by I/
4061     #tr #H @conj try @refl try assumption
4062| 7: #ty #op #e
4063     #Hsim @(exec_expr_expr_elim … Hsim) #v1 #v2 #trace #Hvalue_eq
4064     lapply (unary_operation_value_eq E op v1 v2 (typeof e) Hvalue_eq)
4065     cases (sem_unary_operation op v1 (typeof e)) normalize nodelta
4066     [ 1: #_ @I
4067     | 2: #r1 #H elim (H r1 (refl ??)) #r1' * #Heq >Heq
4068           normalize /2/ ]
4069| 8: #ty #op #e1 #e2 #Hsim1 #Hsim2
4070     @(exec_expr_expr_elim … Hsim1) #v1 #v2 #trace #Hvalue_eq
4071     cases (exec_expr ge en1 m1 e2) in Hsim2;
4072     [ 2: #error // ]
4073     * #val #trace normalize in ⊢ (% → ?); #Hsim2
4074     elim (Hsim2 ? (refl ??)) * #val2 #trace2 * #Hexec2 * #Hvalue_eq2 #Htrace >Hexec2
4075     whd in match (m_bind ?????); whd in match (m_bind ?????);
4076     lapply (binary_operation_value_eq E op … (typeof e1) (typeof e2) ?? Hvalue_eq Hvalue_eq2 (me_inj … Hext))
4077     cases (sem_binary_operation op v1 (typeof e1) val (typeof e2) m1)
4078     [ 1: #_ // ]
4079     #opval #Hop elim (Hop ? (refl ??)) #opval' * #Hopval_eq  #Hvalue_eq_opval
4080     >Hopval_eq normalize destruct /2 by conj/
4081| 9: #ty #cast_ty #e #Hsim @(exec_expr_expr_elim … Hsim)
4082     #v1 #v2 #trace #Hvalue_eq lapply (cast_value_eq E m1 m2 … Hvalue_eq (typeof e) cast_ty)
4083     cases (exec_cast m1 v1 (typeof e) cast_ty)
4084     [ 2: #error #_ normalize @I
4085     | 1: #res #H lapply (H res (refl ??)) whd in match (m_bind ?????);
4086          * #res' * #Hexec_cast >Hexec_cast #Hvalue_eq normalize nodelta
4087          @conj // ]
4088| 10: #ty #e1 #e2 #e3 #Hsim1 #Hsim2 #Hsim3
4089     @(exec_expr_expr_elim … Hsim1) #v1 #v2 #trace #Hvalue_eq
4090     lapply (bool_of_val_value_eq E v1 v2 Hvalue_eq (typeof e1))
4091     cases (exec_bool_of_val ? (typeof e1)) #b
4092     [ 2: #_ normalize @I ]
4093     #H lapply (H ? (refl ??)) #Hexec >Hexec normalize
4094     cases b normalize nodelta
4095     [ 1: (* true branch *)
4096          cases (exec_expr ge en1 m1 e2) in Hsim2;
4097          [ 2: #error normalize #_ @I
4098          | 1: * #e2v #e2tr normalize #H elim (H ? (refl ??))
4099               * #e2v' #e2tr' * #Hexec2 >Hexec2 * #Hvalue_eq2 #Htrace_eq2 normalize
4100                    destruct @conj try // ]
4101     | 2: (* false branch *)
4102          cases (exec_expr ge en1 m1 e3) in Hsim3;
4103          [ 2: #error normalize #_ @I
4104          | 1: * #e3v #e3tr normalize #H elim (H ? (refl ??))
4105               * #e3v' #e3tr' * #Hexec3 >Hexec3 * #Hvalue_eq3 #Htrace_eq3 normalize
4106               destruct @conj // ] ]
4107| 11,12: #ty #e1 #e2 #Hsim1 #Hsim2
4108     @(exec_expr_expr_elim … Hsim1) #v1 #v1' #trace #Hvalue_eq
4109     lapply (bool_of_val_value_eq E v1 v1' Hvalue_eq (typeof e1))     
4110     cases (exec_bool_of_val v1 (typeof e1))
4111     [ 2,4:  #error #_ normalize @I ]
4112     #b cases b #H lapply (H ? (refl ??)) #Heq >Heq
4113     whd in match (m_bind ?????);
4114     whd in match (m_bind ?????);
4115     [ 2,3: normalize @conj try @refl try @vint_eq ]
4116     cases (exec_expr ge en1 m1 e2) in Hsim2;
4117     [ 2,4: #error #_ normalize @I ]
4118     * #v2 #tr2 whd in ⊢ (% → %); #H2 normalize nodelta elim (H2 ? (refl ??))
4119     * #v2' #tr2' * #Heq2 * #Hvalue_eq2 #Htrace2 >Heq2 normalize nodelta
4120     lapply (bool_of_val_value_eq E v2 v2' Hvalue_eq2 (typeof e2))
4121     cases (exec_bool_of_val v2 (typeof e2))
4122     [ 2,4: #error #_ normalize @I ]
4123     #b2 #H3 lapply (H3 ? (refl ??)) #Heq3 >Heq3 normalize nodelta
4124     destruct @conj try @conj //
4125     cases b2 whd in match (of_bool ?); @vint_eq
4126| 13: #ty #ty' cases ty
4127     [ 1: | 2: #sz #sg | 3: #fl | 4: #ty | 5: #ty #n
4128     | 6: #tl #ty | 7: #id #fl | 8: #id #fl | 9: #ty ]
4129     whd in match (exec_expr ????); whd
4130     * #v #trace #Heq destruct %{〈Vint sz (repr sz (sizeof ty')), E0〉}
4131     @conj try @refl @conj //
4132| 14: #ty #ed #aggregty #i #Hsim whd * * #b #o #tr normalize nodelta
4133    whd in match (exec_lvalue' ?????);
4134    whd in match (exec_lvalue' ge' en2 m2 (Efield (Expr ed aggregty) i) ty);
4135    whd in match (typeof ?);
4136    cases aggregty in Hsim;
4137    [ 1: | 2: #sz' #sg' | 3: #fl' | 4: #ty' | 5: #ty' #n'
4138    | 6: #tl' #ty' | 7: #id' #fl' | 8: #id' #fl' | 9: #ty' ]
4139    normalize nodelta #Hsim
4140    [ 1,2,3,4,5,6,9: #Habsurd destruct (Habsurd) ]
4141    whd in match (m_bind ?????);
4142    whd in match (m_bind ?????);
4143    whd in match (exec_lvalue ge en1 m1 (Expr ed ?));
4144    cases (exec_lvalue' ge en1 m1 ed ?) in Hsim;
4145    [ 2,4: #error #_ normalize in ⊢ (% → ?); #Habsurd destruct (Habsurd) ]
4146    * * #b1 #o1 #tr1 whd in ⊢ (% → ?); #H elim (H ? (refl ??))
4147    * * #b1' #o1' #tr1' * #Hexec normalize nodelta * #Hvalue_eq #Htrace_eq
4148    whd in match (exec_lvalue ????); >Hexec normalize nodelta
4149    [ 2: #Heq destruct (Heq) %{〈 b1',o1',tr1'〉} @conj //
4150         normalize @conj // ]
4151    cases (field_offset i fl')
4152    [ 2: #error normalize #Habsurd destruct (Habsurd) ]
4153    #offset whd in match (m_bind ?????); #Heq destruct (Heq)
4154    whd in match (m_bind ?????);
4155    %{〈b1',shift_offset (bitsize_of_intsize I32) o1' (repr I32 offset),tr1'〉} @conj
4156    destruct // normalize nodelta @conj try @refl @vptr_eq
4157    -H lapply (value_eq_ptr_inversion … Hvalue_eq) * #p2 * #Hptr_eq
4158    whd in match (pointer_translation ??);     
4159    whd in match (pointer_translation ??);
4160    cases (E b)
4161    [ 1: normalize nodelta #Habsurd destruct (Habsurd) ]
4162    * #b' #o' normalize nodelta #Heq destruct (Heq) destruct (Hptr_eq)
4163    cut (offset_plus (mk_offset (addition_n offset_size
4164                                      (offv o1)
4165                                      (sign_ext (bitsize_of_intsize I32) offset_size (repr I32 offset)))) o'
4166          = (shift_offset (bitsize_of_intsize I32) (offset_plus o1 o') (repr I32 offset)))
4167    [ whd in match (shift_offset ???) in ⊢ (???%);
4168      whd in match (offset_plus ??) in ⊢ (??%%);
4169      /3 by associative_addition_n, commutative_addition_n, refl/ ]
4170    #Heq >Heq @refl
4171| 15: #ty #l #e #Hsim
4172     @(exec_expr_expr_elim … Hsim) #v1 #v2 #trace #Hvalue_eq normalize nodelta @conj //
4173| 16: *
4174  [ 1: #sz #i | 2: #fl | 3: #var_id | 4: #e1 | 5: #e1 | 6: #op #e1 | 7: #op #e1 #e2 | 8: #cast_ty #e1
4175  | 9: #cond #iftrue #iffalse | 10: #e1 #e2 | 11: #e1 #e2 | 12: #sizeofty | 13: #e1 #field | 14: #cost #e1 ]
4176  #ty normalize in ⊢ (% → ?);
4177  [ 3,4,13: @False_ind
4178  | *: #_ normalize #a1 #Habsurd destruct (Habsurd) ]
4179] qed.
4180
4181
4182(*
4183lemma related_globals_exprlist_simulation : ∀ge,ge',en,m.
4184related_globals ? fundef_switch_removal ge ge' →
4185∀args. res_sim ? (exec_exprlist ge en m args ) (exec_exprlist ge' en m args).
4186#ge #ge' #en #m #Hrelated #args
4187elim args
4188[ 1: /3/
4189| 2: #hd #tl #Hind normalize
4190     elim (sim_related_globals ge ge' en m Hrelated)
4191     #Hexec_sim #Hlvalue_sim lapply (Hexec_sim hd)
4192     cases (exec_expr ge en m hd)
4193     [ 2: #error #_  @SimFail /2 by refl, ex_intro/
4194     | 1: * #val_hd #trace_hd normalize nodelta
4195          cases Hind
4196          [ 2: * #error #Heq >Heq #_ @SimFail /2 by ex_intro/
4197          | 1: cases (exec_exprlist ge en m tl)
4198               [ 2: #error #_ #Hexec_hd @SimFail /2 by ex_intro/
4199               | 1: * #values #trace #H >(H 〈values, trace〉 (refl ??))
4200                    normalize nodelta #Hexec_hd @SimOk * #values2 #trace2 #H2
4201                    cases Hexec_hd
4202                    [ 2: * #error #Habsurd destruct (Habsurd)
4203                    | 1: #H >(H 〈val_hd, trace_hd〉 (refl ??)) normalize destruct // ]
4204] ] ] ] qed.
4205*)
4206
4207(* The return type of any function is invariant under switch removal *)
4208lemma fn_return_simplify : ∀f. fn_return (\fst (function_switch_removal f)) = fn_return f.
4209#f elim f #r #args #vars #body whd in match (function_switch_removal ?); @refl
4210qed.
4211
4212(* Similar stuff for fundefs *)
4213lemma fundef_type_simplify : ∀clfd. type_of_fundef clfd = type_of_fundef (fundef_switch_removal clfd).
4214* // qed.
4215
4216(*
4217lemma expr_fresh_lift :
4218  ∀e,u,id.
4219      fresh_for_expression e u →
4220      fresh_for_univ SymbolTag id u →
4221      fresh_for_univ SymbolTag (max_of_expr e id) u.
4222#e #u #id
4223normalize in match (fresh_for_expression e u);
4224#H1 #H2
4225>max_of_expr_rewrite
4226normalize in match (fresh_for_univ ???);
4227cases (max_of_expr e ?) in H1; #p #H1
4228cases id in H2; #p' #H2
4229normalize nodelta
4230cases (leb p p') normalize nodelta
4231[ 1: @H2 | 2: @H1 ]
4232qed. *)
4233
4234lemma while_fresh_lift : ∀e,s,u.
4235   fresh_for_expression e u → fresh_for_statement s u → fresh_for_statement (Swhile e s) u.
4236#e #s * #u whd in ⊢ (% → % → %); whd in match (max_of_statement (Swhile ??));
4237cases (max_of_expr e) #e cases (max_of_statement s) #s normalize
4238cases (leb e s) try /2/
4239qed.
4240
4241(*
4242lemma while_commute : ∀e0, s0, us0. Swhile e0 (switch_removal s0 us0) = (sw_rem (Swhile e0 s0) us0).
4243#e0 #s0 #us0 normalize
4244cases (switch_removal s0 us0) * #body #newvars #u' normalize //
4245qed.*)
4246
4247lemma dowhile_fresh_lift : ∀e,s,u.
4248   fresh_for_expression e u → fresh_for_statement s u → fresh_for_statement (Sdowhile e s) u.
4249#e #s * #u whd in ⊢ (% → % → %); whd in match (max_of_statement (Sdowhile ??));
4250cases (max_of_expr e) #e cases (max_of_statement s) #s normalize
4251cases (leb e s) try /2/
4252qed.
4253(*
4254lemma dowhile_commute : ∀e0, s0, us0. Sdowhile e0 (sw_rem s0 us0) = (sw_rem (Sdowhile e0 s0) us0).
4255#e0 #s0 #us0 normalize
4256cases (switch_removal s0 us0) * #body #newvars #u' normalize //
4257qed.*)
4258
4259lemma for_fresh_lift : ∀cond,step,body,u.
4260  fresh_for_statement step u →
4261  fresh_for_statement body u →
4262  fresh_for_expression cond u →
4263  fresh_for_statement (Sfor Sskip cond step body) u.
4264#cond #step #body #u
4265whd in ⊢ (% → % → % → %); whd in match (max_of_statement (Sfor ????));
4266cases (max_of_statement step) #s
4267cases (max_of_statement body) #b
4268cases (max_of_expr cond) #c
4269whd in match (max_of_statement Sskip);
4270>(max_id_commutative least_identifier)
4271>max_id_one_neutral normalize nodelta
4272normalize elim u #u
4273cases (leb s b) cases (leb c b) cases (leb c s) try /2/
4274qed.
4275
4276(*
4277lemma for_commute : ∀e,stm1,stm2,u,uA.
4278   (uA=\snd  (switch_removal stm1 u)) →
4279   sw_rem (Sfor Sskip e stm1 stm2) u = (Sfor Sskip e (sw_rem stm1 u) (sw_rem stm2 uA)).
4280#e #stm1 #stm2 #u #uA #HuA
4281whd in match (sw_rem (Sfor ????) u);
4282whd in match (switch_removal ??);   
4283destruct
4284normalize in match (\snd (switch_removal Sskip u));
4285whd in match (sw_rem stm1 u);
4286cases (switch_removal stm1 u)
4287* #stm1' #fresh_vars #uA normalize nodelta
4288whd in match (sw_rem stm2 uA);
4289cases (switch_removal stm2 uA)
4290* #stm2' #fresh_vars2 #uB normalize nodelta
4291//
4292qed.*)
4293
4294(*
4295lemma simplify_is_not_skip: ∀s,u.s ≠ Sskip → ∃pf. is_Sskip (sw_rem s u) = inr … pf.
4296*
4297[ 1: #u * #Habsurd elim (Habsurd (refl ? Sskip))
4298| 2: #e1 #e2 #u #_
4299     whd in match (sw_rem ??);
4300     whd in match (is_Sskip ?);
4301     try /2 by refl, ex_intro/
4302| 3: #ret #f #args #u
4303     whd in match (sw_rem ??);
4304     whd in match (is_Sskip ?);
4305     try /2 by refl, ex_intro/
4306| 4: #s1 #s2 #u
4307     whd in match (sw_rem ??);
4308     whd in match (switch_removal ??);     
4309     cases (switch_removal ? ?) * #a #b #c #d normalize nodelta
4310     cases (switch_removal ? ?) * #e #f #g normalize nodelta     
4311     whd in match (is_Sskip ?);
4312     try /2 by refl, ex_intro/
4313| 5: #e #s1 #s2 #u #_
4314     whd in match (sw_rem ??);
4315     whd in match (switch_removal ??);     
4316     cases (switch_removal ? ?) * #a #b #c normalize nodelta
4317     cases (switch_removal ? ?) * #e #f #h normalize nodelta
4318     whd in match (is_Sskip ?);
4319     try /2 by refl, ex_intro/
4320| 6,7: #e #s #u #_
4321     whd in match (sw_rem ??);
4322     whd in match (switch_removal ??);     
4323     cases (switch_removal ? ?) * #a #b #c normalize nodelta
4324     whd in match (is_Sskip ?);
4325     try /2 by refl, ex_intro/
4326| 8: #s1 #e #s2 #s3 #u #_     
4327     whd in match (sw_rem ??);
4328     whd in match (switch_removal ??);     
4329     cases (switch_removal ? ?) * #a #b #c normalize nodelta
4330     cases (switch_removal ? ?) * #e #f #g normalize nodelta
4331     cases (switch_removal ? ?) * #i #j #k normalize nodelta
4332     whd in match (is_Sskip ?);
4333     try /2 by refl, ex_intro/
4334| 9,10: #u #_     
4335     whd in match (is_Sskip ?);
4336     try /2 by refl, ex_intro/
4337| 11: #e #u #_
4338     whd in match (is_Sskip ?);
4339     try /2 by refl, ex_intro/
4340| 12: #e #ls #u #_
4341     whd in match (sw_rem ??);
4342     whd in match (switch_removal ??);
4343     cases (switch_removal_branches ? ?) * #a #b #c normalize nodelta
4344     cases (fresh ??) #e #f normalize nodelta
4345     normalize in match (simplify_switch ???);
4346     cases (fresh ? f) #g #h normalize nodelta
4347     cases (produce_cond ????) * #k #l #m normalize nodelta
4348     whd in match (is_Sskip ?);
4349     try /2 by refl, ex_intro/
4350| 13,15: #lab #st #u #_
4351     whd in match (sw_rem ??);
4352     whd in match (switch_removal ??);
4353     cases (switch_removal ? ?) * #a #b #c normalize nodelta
4354     whd in match (is_Sskip ?);
4355     try /2 by refl, ex_intro/
4356| 14: #lab #u     
4357     whd in match (is_Sskip ?);
4358     try /2 by refl, ex_intro/ ]
4359qed.
4360*)
4361
4362(*
4363lemma sw_rem_commute : ∀stm,u.
4364  (\fst (\fst (switch_removal stm u))) = sw_rem stm u.
4365#stm #u whd in match (sw_rem stm u); // qed.
4366*)
4367
4368lemma fresh_for_statement_inv :
4369  ∀u,s. fresh_for_statement s u →
4370        match u with
4371        [ mk_universe p ⇒ le (p0 one) p ].
4372* #p #s whd in match (fresh_for_statement ??);
4373cases (max_of_statement s) #s
4374normalize /2/ qed.
4375
4376lemma fresh_for_Sskip :
4377  ∀u,s. fresh_for_statement s u → fresh_for_statement Sskip u.
4378#u #s #H lapply (fresh_for_statement_inv … H) elim u /2/ qed.
4379
4380lemma fresh_for_Sbreak :
4381  ∀u,s. fresh_for_statement s u → fresh_for_statement Sbreak u.
4382#u #s #H lapply (fresh_for_statement_inv … H) elim u /2/ qed.
4383
4384lemma fresh_for_Scontinue :
4385  ∀u,s. fresh_for_statement s u → fresh_for_statement Scontinue u.
4386#u #s #H lapply (fresh_for_statement_inv … H) elim u /2/ qed.
4387
4388(*
4389lemma switch_removal_eq : ∀s,u. ∃res,fvs,u'. switch_removal s u = 〈res, fvs, u'〉.
4390#s #u elim (switch_removal s u) * #res #fvs #u'
4391%{res} %{fvs} %{u'} //
4392qed.
4393
4394lemma switch_removal_branches_eq : ∀switchcases, u. ∃res,fvs,u'. switch_removal_branches switchcases u = 〈res, fvs, u'〉.
4395#switchcases #u elim (switch_removal_branches switchcases u) * #res #fvs #u'
4396%{res} %{fvs} %{u'} //
4397qed.
4398*)
4399
4400lemma produce_cond_eq : ∀e,ls,u,exit_label. ∃s,lab,u'. produce_cond e ls u exit_label = 〈s,lab,u'〉.
4401#e #ls #u #exit_label cases (produce_cond e ls u exit_label) *
4402#s #lab #u' %{s} %{lab} %{u'} //
4403qed.
4404
4405(* TODO: this lemma ought to be in a more central place, along with its kin of SimplifiCasts.ma ... *)
4406lemma neq_intsize : ∀s1,s2. s1 ≠ s2 → eq_intsize s1 s2 = false.
4407* * *
4408[ 1,5,9: #H @(False_ind … (H (refl ??)))
4409| *: #_ normalize @refl ]
4410qed.
4411
4412lemma exec_expr_int : ∀ge,e,m,expr.
4413    (∃sz,n,tr. exec_expr ge e m expr = (OK ? 〈Vint sz n, tr〉)) ∨ (∀sz,n,tr. exec_expr ge e m expr ≠ (OK ? 〈Vint sz n, tr〉)).
4414#ge #e #m #expr cases (exec_expr ge e m expr)
4415[ 2: #error %2 #sz #n #tr % #H destruct (H)
4416| 1: * #val #trace cases val
4417     [ 2: #sz #n %1 %{sz} %{n} %{trace} @refl
4418     | 3: #fl | 4: | 5: #ptr ]
4419     %2 #sz #n #tr % #H destruct (H)
4420] qed.
4421
4422(*
4423lemma exec_expr_related : ∀ge,ge',e,m,cond,v,tr.
4424  exec_expr ge e m cond = OK ? 〈v,tr〉 →
4425  (res_sim ? (exec_expr ge e m cond) (exec_expr ge' e m cond)) →
4426  exec_expr ge' e m cond = OK ? 〈v,tr〉.
4427#ge #ge' #e #m #cond #v #tr #H *
4428[ 1: #Hsim >(Hsim ? H) //
4429| 2: * #error >H #Habsurd destruct (Habsurd) ]
4430qed. *)
4431
4432(*
4433lemma switch_simulation :
4434∀ge,ge',e,m,cond,f,condsz,condval,switchcases,k,k',condtr,u.
4435 switch_cont_sim k k' →
4436 (exec_expr ge e m cond=OK (val×trace) 〈Vint condsz condval,condtr〉) →
4437 fresh_for_statement (Sswitch cond switchcases) u →
4438 ∃tr'.
4439 (eventually ge'
4440  (λs2':state
4441   .switch_state_sim
4442    (State f
4443     (seq_of_labeled_statement (select_switch condsz condval switchcases))
4444     (Kswitch k) e m) s2')
4445  (State (function_switch_removal f) (sw_rem (Sswitch cond switchcases) u) k' e m)
4446  tr').
4447#ge #ge' #e #m #cond #f #condsz #condval #switchcases #k #k' #tr #u #Hsim_cont #Hexec_cond #Hfresh
4448whd in match (sw_rem (Sswitch cond switchcases) u);
4449whd in match (switch_removal (Sswitch cond switchcases) u);
4450cases switchcases in Hfresh;
4451[ 1: #default_statement #Hfresh_for_default
4452     whd in match (switch_removal_branches ??);
4453     whd in match (select_switch ???); whd in match (seq_of_labeled_statement ?);
4454     elim (switch_removal_eq default_statement u)
4455     #default_statement' * #Hdefault_statement_sf * #Hnew_vars * #u' #Hdefault_statement_eq >Hdefault_statement_eq
4456     normalize nodelta
4457     cut (u' = (\snd (switch_removal default_statement u)))
4458     [ 1: >Hdefault_statement_eq // ] #Heq_u'
4459     cut (fresh_for_statement (Sswitch cond (LSdefault default_statement)) u')
4460     [ 1: >Heq_u' @switch_removal_fresh @Hfresh_for_default ] -Heq_u' #Heq_u'
4461     lapply (fresh_for_univ_still_fresh u' ? Heq_u') cases (fresh ? u')
4462     #switch_tmp #uv2 #Hfreshness lapply (Hfreshness ?? (refl ? 〈switch_tmp, uv2〉))
4463     -Hfreshness #Heq_uv2 (* We might need to produce some lookup hypotheses here *)
4464     normalize nodelta
4465     whd in match (simplify_switch (Expr ??) ?? uv2);
4466     lapply (fresh_for_univ_still_fresh uv2 ? Heq_uv2) cases (fresh ? uv2)
4467     #exit_label #uv3 #Hfreshness lapply (Hfreshness ?? (refl ? 〈exit_label, uv3〉))
4468     -Hfreshness #Heq_uv3
4469     normalize nodelta whd in match (add_starting_lbl_list ????);
4470     lapply (fresh_for_univ_still_fresh uv3 ? Heq_uv3) cases (fresh ? uv3)
4471     #default_lab #uv4 #Hfreshness lapply (Hfreshness ?? (refl ? 〈default_lab, uv4〉))
4472     -Hfreshness #Heq_uv4
4473     normalize nodelta
4474     @(eventually_later ge' ?? E0)
4475     whd in match (exec_step ??);
4476     %{(State (function_switch_removal f)
4477          (Sassign (Expr (Evar switch_tmp) (typeof cond)) cond)
4478          (Kseq
4479          (Ssequence
4480            (Slabel default_lab (convert_break_to_goto default_statement' exit_label))
4481            (Slabel exit_label Sskip))
4482          k') e m)} @conj try //
4483     @(eventually_later ge' ?? E0)
4484     whd in match (exec_step ??);
4485     
4486@chthulhu | @chthulhu
4487qed. *)
4488
4489
4490
4491(* Main theorem. To be ported and completed to memory injections. TODO *)
4492(*
4493theorem switch_removal_correction : ∀ge, ge'.
4494  related_globals ? fundef_switch_removal ge ge' →
4495  ∀s1, s1', tr, s2.
4496  switch_state_sim s1 s1' →
4497  exec_step ge s1 = Value … 〈tr,s2〉 →
4498  eventually ge' (λs2'. switch_state_sim s2 s2') s1' tr.
4499#ge #ge' #Hrelated #s1 #s1' #tr #s2 #Hsim_state #Hexec_step
4500inversion Hsim_state
4501[ 1: (* regular state *)
4502  #u #f #s #k #k' #m #m' #result #en #en' #f' #vars
4503  #Hu_fresh #Hen_eq #Hf_eq #Hen_eq' #Hswitch_removal #Hsim_cont #Hs1_eq #Hs1_eq' #_
4504
4505  lapply (sim_related_globals ge ge' e m Hrelated) *
4506  #Hexpr_related #Hlvalue_related
4507  >Hs1_eq in Hexec_step; whd in ⊢ ((??%?) → ?);
4508  cases s in Hu_fresh Heq_env;
4509 
4510
4511theorem switch_removal_correction : ∀ge, ge'.
4512  related_globals ? fundef_switch_removal ge ge' →
4513  ∀s1, s1', tr, s2.
4514  switch_state_sim s1 s1' →
4515  exec_step ge s1 = Value … 〈tr,s2〉 →
4516  eventually ge' (λs2'. switch_state_sim s2 s2') s1' tr.
4517#ge #ge' #Hrelated #s1 #s1' #tr #s2 #Hsim_state #Hexec_step
4518inversion Hsim_state
4519[ 1: (* regular state *)
4520  #u #f #s #k #k' #e #e' #m #m' #Hu_fresh #Heq_env #Hsim_cont #Hs1_eq #Hs1_eq' #_
4521  lapply (sim_related_globals ge ge' e m Hrelated) *
4522  #Hexpr_related #Hlvalue_related
4523  >Hs1_eq in Hexec_step; whd in ⊢ ((??%?) → ?);
4524  cases s in Hu_fresh Heq_env;
4525  (* Perform the intros for the statements*)
4526  [ 1: | 2: #lhs #rhs | 3: #retv #func #args | 4: #stm1 #stm2 | 5: #cond #iftrue #iffalse | 6: #cond #body
4527  | 7: #cond #body | 8: #init #cond #step #body | 9,10: | 11: #retval | 12: #cond #switchcases | 13: #lab #body
4528  | 14: #lab | 15: #cost #body ]
4529  #Hu_fresh #Heq_env
4530  [ 1: (* Skip *)
4531    whd in match (sw_rem ??);
4532    inversion Hsim_cont normalize nodelta
4533    [ 1: #Hk #Hk' #_ #Hexec_step
4534         @(eventually_now ????) whd in match (exec_step ??); >fn_return_simplify
4535         cases (fn_return f) in Hexec_step;
4536         [ 1,10: | 2,11: #sz #sg | 3,12: #fsz | 4,13: #rg #ptr_ty | 5,14: #rg #array_ty #array_sz | 6,15: #domain #codomain
4537         | 7,16: #structname #fieldspec | 8,17: #unionname #fieldspec | 9,18: #rg #id ]
4538         normalize nodelta
4539         [ 1,2: #H whd in match (ret ??) in H ⊢ %; destruct (H)
4540                %{(Returnstate Vundef Kstop (free_list m' (blocks_of_env e')))} @conj try //
4541                normalize in Heq_env; destruct (Heq_env)
4542                %3 //
4543(*                cut (blocks_of_env e = blocks_of_env e')
4544                [ normalize in match (\snd (\fst (switch_removal ??))) in Henv_incl;
4545                  lapply (environment_extension_nil … Henv_incl) #Himap_eq @(blocks_of_env_eq … Himap_eq) ]
4546                #Heq >Heq %3 // *)
4547         | *: #H destruct (H) ]
4548    | 2: #s0 #k0 #k0' #us #Hus_fresh #Hsim_cont #_ #Hk #Hk' #_ #Heq
4549         whd in match (ret ??) in Heq; destruct (Heq)
4550         @(eventually_now ????) whd in match (exec_step ??);
4551         %{(State (\fst (function_switch_removal f)) (sw_rem s0 us) k0' e' m')} @conj try //
4552         %1 try //   
4553    | 3: #e0 #s0 #k0 #k0' #us #Hus_fresh #Hsim_cont #_ #Hk #Hk' #_ #Heq
4554         @(eventually_now ????) whd in match (exec_step ??);
4555         whd in match (ret ??) in Heq; destruct (Heq)
4556         %{(State (function_switch_removal f) (Swhile e0 (sw_rem s0 us)) k0' e m)} @conj try //
4557         >while_commute %1 try //
4558    | 4: #e0 #s0 #k0 #k0' #us #Hus_fresh #Hsim_cont #_ #Hk #Hk' #_ #Heq
4559         @(eventually_now ????) whd in match (exec_step ??);
4560         lapply (Hexpr_related e0)
4561         cases (exec_expr ge e m e0) in Heq;
4562         [ 2: #error normalize in ⊢ (% → ?); #Habsurd destruct (Habsurd)
4563         | 1: * #b #tr whd in match (m_bind ?????); #Heq
4564              *
4565              [ 2: * #error #Habsurd destruct (Habsurd)
4566              | 1: #Hrelated >(Hrelated 〈b,tr〉 (refl ? (OK ? 〈b,tr〉)))
4567                   whd in match (bindIO ??????);
4568                   cases (exec_bool_of_val b (typeof e0)) in Heq;
4569                   [ 2: #error whd in match (bindIO ??????); #Habsurd destruct (Habsurd)
4570                   | 1: * whd in match (bindIO ??????); #Heq destruct (Heq)
4571                        whd in match (bindIO ??????);
4572                        [ 1: %{(State (function_switch_removal f) (Sdowhile e0 (sw_rem s0 us)) k0' e m)}
4573                             @conj // >dowhile_commute %1 try //
4574                        | 2: %{(State (function_switch_removal f) Sskip k0' e m)}
4575                             @conj // %1{us} try //
4576                             @(fresh_for_Sskip … Hus_fresh)
4577                        ] ] ] ]
4578    | 5: #e0 #stm1 #stm2 #k0 #k0' #u #Hu_fresh #Hsim_cont #_ #Hk #Hk' #_ #Heq
4579         @(eventually_now ????) whd in match (exec_step ??);
4580         whd in match (ret ??) in Heq; destruct
4581         %{(State (function_switch_removal f) (sw_rem (Sfor Sskip e0 stm1 stm2) u) k0' e m)}
4582         @conj try // %1{u} try //
4583    | 6: #e0 #stm1 #stm2 #k0 #k0' #us #uA #Hfresh #HeqA #Hsim_cont #_ #Hk #Hk' #_ #Heq
4584         @(eventually_now ????) whd in match (exec_step ??); whd in match (ret ??) in Heq;
4585         destruct (Heq)
4586         %{(State (function_switch_removal f) (sw_rem stm1 us) (Kfor3 e0 (sw_rem stm1 us) (sw_rem stm2 uA) k0') e m)}
4587         @conj try // %1
4588         [ 2: @swc_for3 //
4589         | 1: elim (substatement_fresh (Sfor Sskip e0 stm1 stm2) us Hfresh) * // ]
4590    | 7: #e0 #stm1 #stm2 #k0 #k0' #u #uA #Hfresh #HeqA #Hsim_cont #_ #Hk #Hk' #_ #Heq
4591         @(eventually_now ????) whd in match (exec_step ??); whd in match (ret ??) in Heq;
4592         destruct (Heq)
4593         %{(State (function_switch_removal f) (Sfor Sskip e0 (sw_rem stm1 u) (sw_rem stm2 uA)) k0' e m)}
4594         @conj try // <(for_commute ??? u uA) try // %1
4595         [ 2: assumption
4596         | 1: >HeqA elim (substatement_fresh (Sfor Sskip e0 stm1 stm2) u Hfresh) * // ]
4597    | 8: #k0 #k0' #Hsim_cont #_ #Hk #Hk' #_ whd in match (ret ??) in ⊢ (% → ?);
4598         #Heq @(eventually_now ????) whd in match (exec_step ??);
4599         destruct (Heq)
4600         %{(State (function_switch_removal f) Sskip k0' e m)} @conj //
4601         %1{u} //
4602    | 9: #r #f' #en #k0 #k0' #sim_cont #_ #Hk #Hk' #_ #Heq
4603         @(eventually_now ????) whd in match (exec_step ??);
4604         >fn_return_simplify cases (fn_return f) in Heq;
4605         [ 1: | 2: #sz #sg | 3: #fsz | 4: #rg #ptr_ty | 5: #rg #array_ty #array_sz | 6: #domain #codomain
4606         | 7: #structname #fieldspec | 8: #unionname #fieldspec | 9: #rg #id ]
4607         normalize nodelta
4608         [ 1: #H whd in match (ret ??) in H ⊢ %; destruct (H)
4609              %1{(Returnstate Vundef (Kcall r (function_switch_removal f') en k0') (free_list m (blocks_of_env e)))}
4610              @conj try // %3 destruct //
4611         | *: #H destruct (H) ]     
4612     ]
4613  | 2: (* Sassign *) normalize nodelta #Heq @(eventually_now ????)
4614       whd in match (exec_step ??);
4615       cases lhs in Hu_fresh Heq; #lhs #lhs_type
4616       cases (Hlvalue_related lhs lhs_type)
4617       whd in match (exec_lvalue ge e m (Expr ??));
4618       whd in match (exec_lvalue ge' e m (Expr ??));
4619       [ 2: * #error #Hfail >Hfail #_ #Habsurd normalize in Habsurd; destruct (Habsurd) ]
4620       cases (exec_lvalue' ge e m lhs lhs_type)
4621       [ 2: #error #_ whd in match (m_bind ?????); #_ #Habsurd destruct (Habsurd)
4622       | 1: * * #lblock #loffset #ltrace #H >(H 〈lblock, loffset, ltrace〉 (refl ??))
4623            whd in match (m_bind ?????);
4624            cases (Hexpr_related rhs)
4625            [ 2: * #error #Hfail >Hfail #_
4626                 whd in match (bindIO ??????); #Habsurd destruct (Habsurd)
4627            | 1: cases (exec_expr ge e m rhs)
4628                 [ 2: #error #_ whd in match (bindIO ??????); #_ #Habsurd destruct (Habsurd)
4629                 | 1: * #rval #rtrace #H >(H 〈rval, rtrace〉 (refl ??))
4630                      whd in match (bindIO ??????) in ⊢ (% → % → %);
4631                      cases (opt_to_io io_out io_in ???)
4632                      [ 1: #o #resumption whd in match (bindIO ??????); #_ #Habsurd destruct (Habsurd)
4633                      | 3: #error #_ whd in match (bindIO ??????); #Habsurd destruct (Habsurd)
4634                      | 2: #mem #Hfresh whd in match (bindIO ??????); #Heq destruct (Heq)
4635                           %{(State (function_switch_removal f) Sskip k' e mem)}
4636                           whd in match (bindIO ??????); @conj //
4637                           %1{u} try // @(fresh_for_Sskip … Hfresh)
4638       ] ] ] ]
4639   | 3: (* Scall *) normalize nodelta #Heq @(eventually_now ????)
4640        whd in match (exec_step ??);
4641        cases (Hexpr_related func) in Heq;
4642        [ 2: * #error #Hfail >Hfail #Habsurd normalize in Habsurd; destruct (Habsurd)
4643        | 1: cases (exec_expr ge e m func)
4644             [ 2: #error #_ #Habsurd normalize in Habsurd; destruct (Habsurd)
4645             | 1: * #fval #ftrace #H >(H 〈fval,ftrace〉 (refl ??))
4646                  whd in match (m_bind ?????); normalize nodelta
4647                  lapply (related_globals_exprlist_simulation ge ge' e m Hrelated)
4648                  #Hexprlist_sim cases (Hexprlist_sim args)
4649                  [ 2: * #error #Hfail >Hfail
4650                       whd in match (bindIO ??????); #Habsurd destruct (Habsurd)
4651                  | 1: cases (exec_exprlist ge e m args)
4652                       [ 2: #error #_ whd in match (bindIO ??????); #Habsurd destruct (Habsurd)
4653                       | 1: * #values #values_trace #Hexprlist >(Hexprlist 〈values,values_trace〉 (refl ??))
4654                            whd in match (bindIO ??????) in ⊢ (% → %);
4655                            elim Hrelated #_ #Hfind_funct #_ lapply (Hfind_funct fval)
4656                            cases (find_funct clight_fundef ge fval)
4657                            [ 2: #clfd #Hclfd >(Hclfd clfd (refl ??))
4658                                 whd in match (bindIO ??????) in ⊢ (% → %);
4659                                 >fundef_type_simplify
4660                                 cases (assert_type_eq (type_of_fundef (fundef_switch_removal clfd)) (fun_typeof func))
4661                                 [ 2: #error #Habsurd normalize in Habsurd; destruct (Habsurd)
4662                                 | 1: #Heq whd in match (bindIO ??????) in ⊢ (% → %);
4663                                      cases retv normalize nodelta
4664                                      [ 1: #Heq2 whd in match (ret ??) in Heq2 ⊢ %; destruct
4665                                           %{(Callstate (fundef_switch_removal clfd) values
4666                                                (Kcall (None (block×offset×type)) (function_switch_removal f) e k') m)}
4667                                           @conj try // %2 try // @swc_call //
4668                                      | 2: * #retval_ed #retval_type
4669                                           whd in match (exec_lvalue ge ???);
4670                                           whd in match (exec_lvalue ge' ???);                                     
4671                                           elim (Hlvalue_related retval_ed retval_type)
4672                                           [ 2: * #error #Hfail >Hfail #Habsurd normalize in Habsurd; destruct (Habsurd)
4673                                           | 1: cases (exec_lvalue' ge e m retval_ed retval_type)
4674                                                [ 2: #error #_ whd in match (m_bind ?????); #Habsurd
4675                                                     destruct (Habsurd)
4676                                                | 1: * * #block #offset #trace #Hlvalue >(Hlvalue 〈block,offset,trace〉 (refl ??))
4677                                                     whd in match (m_bind ?????) in ⊢ (% → %);
4678                                                     #Heq destruct (Heq)
4679                                                     %{(Callstate (fundef_switch_removal clfd) values
4680                                                        (Kcall (Some ? 〈block,offset,typeof (Expr retval_ed retval_type)〉)
4681                                                               (function_switch_removal f) e k') m)}
4682                                                     @conj try //
4683                                                     %2 @swc_call //
4684                                ] ] ] ]
4685                            | 1: #_ whd in match (opt_to_io ?????) in ⊢ (% → %);
4686                                 whd in match (bindIO ??????); #Habsurd destruct (Habsurd)
4687       ] ] ] ] ]
4688   | 4: (* Ssequence *) normalize nodelta
4689        whd in match (ret ??) in ⊢ (% → ?); #Heq
4690        @(eventually_now ????)
4691        %{(State (function_switch_removal f)
4692                 (\fst (\fst (switch_removal stm1 u)))
4693                 (Kseq (\fst  (\fst  (switch_removal stm2 (\snd (switch_removal stm1 u))))) k') e m)}
4694        @conj
4695        [ 2: destruct (Heq) %1
4696             [ 1: elim (substatement_fresh (Ssequence stm1 stm2) u Hu_fresh) //
4697             | 2: @swc_seq try // @switch_removal_fresh
4698                  elim (substatement_fresh (Ssequence stm1 stm2) u Hu_fresh) // ]
4699        | 1: whd in match (sw_rem ??); whd in match (switch_removal ??);
4700             cases (switch_removal stm1 u)
4701             * #stm1' #fresh_vars #u' normalize nodelta
4702             cases (switch_removal stm2 u')
4703             * #stm2' #fresh_vars2 #u'' normalize nodelta
4704             whd in match (exec_step ??);
4705             destruct (Heq) @refl
4706        ]
4707   | 5: (* If-then-else *) normalize nodelta
4708        whd in match (ret ??) in ⊢ (% → ?); #Heq
4709        @(eventually_now ????) whd in match (sw_rem ??);
4710        whd in match (switch_removal ??);
4711        elim (switch_removal_eq iftrue u) #iftrue' * #fvs_iftrue * #uA #Hiftrue_eq >Hiftrue_eq normalize nodelta
4712        elim (switch_removal_eq iffalse uA) #iffalse' * #fvs_iffalse * #uB #Hiffalse_eq >Hiffalse_eq normalize nodelta
4713        whd in match (exec_step ??);
4714        cases (Hexpr_related cond) in Heq;
4715        [ 2: * #error #Hfail >Hfail #Habsurd normalize in Habsurd; destruct (Habsurd)
4716        | 1: cases (exec_expr ge e m cond)
4717             [ 2: #error #_ #Habsurd normalize in Habsurd; destruct (Habsurd)
4718             | 1: * #condval #condtrace #Heq >(Heq 〈condval, condtrace〉 (refl ??))
4719                  whd in match (m_bind ?????); whd in match (bindIO ??????) in ⊢ (? → %);
4720                  cases (exec_bool_of_val condval (typeof cond))
4721                  [ 2: #error #Habsurd normalize in Habsurd; destruct (Habsurd)
4722                  | 1: * whd in match (bindIO ??????); normalize nodelta #Heq_condval
4723                       destruct (Heq_condval) whd in match (bindIO ??????);
4724                       normalize nodelta
4725                      [ 1: %{(State (function_switch_removal f) iftrue' k' e m)} @conj try //
4726                           cut (iftrue' = (\fst (\fst (switch_removal iftrue u))))
4727                           [ 1: >Hiftrue_eq normalize // ]
4728                           #Hrewrite >Hrewrite %1
4729                           elim (substatement_fresh (Sifthenelse cond iftrue iffalse) u Hu_fresh) //
4730                      | 2: %{(State (function_switch_removal f) iffalse' k' e m)} @conj try //
4731                           cut (iffalse' = (\fst (\fst (switch_removal iffalse uA))))
4732                           [ 1: >Hiffalse_eq // ]
4733                           #Hrewrite >Hrewrite %1 try //
4734                           cut (uA = (\snd (switch_removal iftrue u)))
4735                           [ 1: >Hiftrue_eq //
4736                           | 2: #Heq_uA >Heq_uA
4737                                elim (substatement_fresh (Sifthenelse cond iftrue iffalse) u Hu_fresh)
4738                                #Hiftrue_fresh #Hiffalse_fresh whd @switch_removal_fresh //
4739       ] ] ] ] ]
4740   | 6: (* While loop *) normalize nodelta
4741        whd in match (ret ??) in ⊢ (% → ?); #Heq
4742        @(eventually_now ????) whd in match (sw_rem ??);
4743        whd in match (switch_removal ??);
4744        elim (switch_removal_eq body u) #body' * #fvs * #uA #Hbody_eq >Hbody_eq normalize nodelta
4745        whd in match (exec_step ??);
4746        cases (Hexpr_related cond) in Heq;
4747        [ 2: * #error #Hfail >Hfail #Habsurd normalize in Habsurd; destruct (Habsurd)
4748        | 1: cases (exec_expr ge e m cond)
4749             [ 2: #error #_ #Habsurd normalize in Habsurd; destruct (Habsurd)
4750             | 1: * #condval #condtrace #Heq >(Heq 〈condval, condtrace〉 (refl ??))
4751                  whd in match (m_bind ?????); whd in match (bindIO ??????) in ⊢ (? → %);
4752                  cases (exec_bool_of_val condval (typeof cond))
4753                  [ 2: #error #Habsurd normalize in Habsurd; destruct (Habsurd)
4754                  | 1: * whd in match (bindIO ??????); normalize nodelta #Heq_condval
4755                       destruct (Heq_condval) whd in match (bindIO ??????);
4756                       normalize nodelta
4757                       [ 1: %{(State (function_switch_removal f) body' (Kwhile cond body' k') e m)} @conj try //
4758                            cut (body' = (\fst (\fst (switch_removal body u))))
4759                            [ 1: >Hbody_eq // ]
4760                            #Hrewrite >Hrewrite %1
4761                            [ 1: elim (substatement_fresh (Swhile cond body) u Hu_fresh) //
4762                            | 2: @swc_while lapply (substatement_fresh (Swhile cond body) u Hu_fresh) // ]
4763                       | 2: %{(State (function_switch_removal f) Sskip k' e m)} @conj //
4764                            %1{u} try // @(fresh_for_Sskip … Hu_fresh)
4765        ] ] ] ]
4766   | 7: (* Dowhile loop *) normalize nodelta
4767        whd in match (ret ??) in ⊢ (% → ?); #Heq
4768        @(eventually_now ????) whd in match (sw_rem ??);
4769        whd in match (switch_removal ??);
4770        elim (switch_removal_eq body u) #body' * #fvs * #uA #Hbody_eq >Hbody_eq normalize nodelta
4771        whd in match (exec_step ??);
4772        destruct (Heq) %{(State (function_switch_removal f) body' (Kdowhile cond body' k') e m)} @conj
4773        try //
4774        cut (body' = (\fst (\fst (switch_removal body u))))
4775        [ 1: >Hbody_eq // ]
4776        #Hrewrite >Hrewrite %1
4777        [ 1: elim (substatement_fresh (Swhile cond body) u Hu_fresh) //
4778        | 2: @swc_dowhile lapply (substatement_fresh (Swhile cond body) u Hu_fresh) // ]
4779   | 8: (* For loop *) normalize nodelta
4780        whd in match (ret ??) in ⊢ (% → ?); #Heq
4781        @(eventually_now ????) whd in match (sw_rem ??);
4782        whd in match (switch_removal ??);
4783        cases (is_Sskip init) in Heq; normalize nodelta #Hinit_Sskip
4784        [ 1: >Hinit_Sskip normalize in match (switch_removal Sskip u); normalize nodelta
4785              elim (switch_removal_eq step u) #step' *  #fvs_step * #uA #Hstep_eq >Hstep_eq normalize nodelta
4786              elim (switch_removal_eq body uA) #body' * #fvs_body * #uB #Hbody_eq >Hbody_eq normalize nodelta
4787              whd in match (exec_step ??);
4788              cases (Hexpr_related cond)
4789              [ 2: * #error #Hfail >Hfail #Habsurd normalize in Habsurd; destruct (Habsurd)
4790              | 1: cases (exec_expr ge e m cond)
4791                   [ 2: #error #_ #Habsurd normalize in Habsurd; destruct (Habsurd)
4792                   | 1: * #condval #condtrace #Heq >(Heq 〈condval, condtrace〉 (refl ??))
4793                        whd in match (m_bind ?????); whd in match (bindIO ??????) in ⊢ (? → %);
4794                        cases (exec_bool_of_val condval (typeof cond))
4795                        [ 2: #error #Habsurd normalize in Habsurd; destruct (Habsurd)
4796                        | 1: * whd in match (bindIO ??????) in ⊢ (% → %); normalize nodelta #Heq_condval
4797                             destruct (Heq_condval)
4798                             [ 1: %{(State (function_switch_removal f) body' (Kfor2 cond step' body' k') e m)} @conj
4799                                  try //
4800                                  cut (body' = (\fst (\fst (switch_removal body uA))))
4801                                  [ 1: >Hbody_eq // ]
4802                                  #Hrewrite >Hrewrite
4803                                  cut (uA = (\snd (switch_removal step u)))
4804                                  [ 1: >Hstep_eq // ] #HuA
4805                                  elim (substatement_fresh (Sfor init cond step body) u Hu_fresh) * *
4806                                  #Hinit_fresh_u #Hcond_fresh_u #Hstep_fresh_u #Hbody_fresh_u %1
4807                                  [ 1: >HuA @switch_removal_fresh assumption
4808                                  | 2: cut (step' = (\fst (\fst (switch_removal step u))))
4809                                       [ >Hstep_eq // ]
4810                                       #Hstep >Hstep @swc_for2 try assumption
4811                                       @for_fresh_lift try assumption ]
4812                             | 2: %{(State (function_switch_removal f) Sskip k' e m)} @conj
4813                                   try // %1{u} try @(fresh_for_Sskip … Hu_fresh) assumption
4814               ] ] ] ]
4815        | 2: #Heq
4816             elim (switch_removal_eq init u) #init' * #fvs_init * #uA #Hinit_eq >Hinit_eq normalize nodelta
4817             elim (switch_removal_eq step uA) #step' * #fvs_step * #uB #Hstep_eq >Hstep_eq normalize nodelta
4818             elim (switch_removal_eq body uB) #body' * #fvs_body * #uC #Hbody_eq >Hbody_eq normalize nodelta
4819             whd in match (exec_step ??);
4820             cut (init' = (\fst (\fst (switch_removal init u)))) [ 1: >Hinit_eq // ]
4821             #Hinit >Hinit elim (simplify_is_not_skip ? u Hinit_Sskip)
4822             whd in match (sw_rem ??) in ⊢ (? → % → ?); #pf #Hskip >Hskip normalize nodelta
4823             whd in match (ret ??); destruct (Heq)
4824             %{(State (function_switch_removal f) (\fst  (\fst  (switch_removal init u))) (Kseq (Sfor Sskip cond step' body') k') e m)}
4825             @conj try //
4826             cut (step' = (\fst (\fst (switch_removal step uA)))) [ >Hstep_eq // ] #Hstep' >Hstep'
4827             cut (body' = (\fst (\fst (switch_removal body uB)))) [ >Hbody_eq // ] #Hbody' >Hbody'
4828             <for_commute [ 2: >Hstep_eq // ]
4829             elim (substatement_fresh (Sfor init cond step body) u Hu_fresh) * *
4830             #Hinit_fresh_u #Hcond_fresh_u #Hstep_fresh_u #Hbody_fresh_u %1{u} try assumption
4831             @swc_seq try // @for_fresh_lift
4832             cut (uA = (\snd (switch_removal init u))) [ 1,3,5: >Hinit_eq // ] #HuA_eq
4833             >HuA_eq @switch_removal_fresh assumption       
4834       ]
4835   | 9: (* break *) normalize nodelta
4836        inversion Hsim_cont
4837        [ 1: #Hk #Hk' #_       
4838        | 2: #stm' #k0 #k0' #u0 #Hstm_fresh' #Hconst_cast0 #_ #Hk #Hk' #_
4839        | 3: #cond #body #k0 #k0' #u0 #Hwhile_fresh #Hconst_cast0 #_ #Hk #Hk' #_
4840        | 4: #cond #body #k0 #k0' #u0 #Hdowhile_fresh #Hcont_cast0 #_ #Hk #Hk' #_
4841        | 5: #cond #step #body #k0 #k0' #u0 #Hfor_fresh #Hcont_cast0 #_ #Hk #Hk' #_
4842        | 6,7: #cond #step #body #k0 #k0' #u0 #uA0 #Hfor_fresh #HuA0 #Hcont_cast0 #_ #Hk #Hk' #_
4843        | 8: #k0 #k0' #Hcont_cast0 #_ #Hk #Hk' #_
4844        | 9: #r #f0 #en0 #k0 #k0' #Hcont_cast #_ #Hk #Hk' #_ ]
4845        normalize nodelta #H try (destruct (H))
4846        whd in match (ret ??) in H; destruct (H)
4847        @(eventually_now ????)
4848        [ 1,4: %{(State (function_switch_removal f) Sbreak k0' e m)} @conj [ 1,3: // | 2,4: %1{u} // ]
4849        | 2,3,5,6: %{(State (function_switch_removal f) Sskip k0' e m)} @conj try // %1{u} // ]
4850    | 10: (* Continue *) normalize nodelta
4851        inversion Hsim_cont
4852        [ 1: #Hk #Hk' #_       
4853        | 2: #stm' #k0 #k0' #u0 #Hstm_fresh' #Hconst_cast0 #_ #Hk #Hk' #_
4854        | 3: #cond #body #k0 #k0' #u0 #Hwhile_fresh #Hconst_cast0 #_ #Hk #Hk' #_
4855        | 4: #cond #body #k0 #k0' #u0 #Hdowhile_fresh #Hcont_cast0 #_ #Hk #Hk' #_
4856        | 5: #cond #step #body #k0 #k0' #u0 #Hfor_fresh #Hcont_cast0 #_ #Hk #Hk' #_
4857        | 6,7: #cond #step #body #k0 #k0' #u0 #uA0 #Hfor_fresh #HuA0 #Hcont_cast0 #_ #Hk #Hk' #_
4858        | 8: #k0 #k0' #Hcont_cast0 #_ #Hk #Hk' #_
4859        | 9: #r #f0 #en0 #k0 #k0' #Hcont_cast #_ #Hk #Hk' #_ ]
4860        normalize nodelta #H try (destruct (H))
4861        @(eventually_now ????) whd in match (exec_step ??); whd in match (ret ??) in H;
4862        destruct (H)
4863        [ 1: %{(State (function_switch_removal f) Scontinue k0' e m)} @conj try // %1{u} try assumption
4864        | 2: %{(State (function_switch_removal f) (Swhile cond (sw_rem body u0)) k0' e m)} @conj try //
4865             >while_commute %1{u0} try assumption
4866        | 3: lapply (Hexpr_related cond) cases (exec_expr ge e m cond) in H;
4867             [ 2: #error #Habsurd normalize in Habsurd; destruct (Habsurd)
4868             | 1: * #condval #trace whd in match (m_bind ?????);
4869                  #Heq *
4870                  [ 2: * #error #Habsurd destruct (Habsurd)
4871                  | 1: #Hexec lapply (Hexec 〈condval,trace〉 (refl ??)) -Hexec #Hexec >Hexec
4872                       whd in match (bindIO ??????);
4873                       cases (exec_bool_of_val condval (typeof cond)) in Heq;
4874                       [ 2: #error #Habsurd normalize in Habsurd; destruct (Habsurd)
4875                       | 1: * #Heq normalize in Heq; destruct (Heq) whd in match (bindIO ??????);
4876                            [ 1: %{(State (function_switch_removal f) (Sdowhile cond (sw_rem body u0)) k0' e m)}
4877                                 @conj try // >dowhile_commute %1{u0} assumption
4878                            | 2: %{(State (function_switch_removal f) Sskip k0' e m)} @conj try //
4879                                 %1{u0} try // @(fresh_for_Sskip … Hdowhile_fresh) ]
4880             ] ] ]
4881        | 4: %{(State (function_switch_removal f) Scontinue k0' e m)} @conj try // %1{u0}
4882             try // @(fresh_for_Scontinue … Hfor_fresh)
4883        | 5: %{(State (function_switch_removal f) (sw_rem step u0) (Kfor3 cond (sw_rem step u0) (sw_rem body uA0) k0') e m)}
4884             @conj try // %1{u0}
4885             elim (substatement_fresh … Hfor_fresh) * * try //
4886             #HSskip #Hcond #Hstep #Hbody
4887             @swc_for3 assumption
4888        | 6: %{(State (function_switch_removal f) Scontinue k0' e m)} @conj try //
4889             %1{u} try //
4890        ]
4891    | 11: (* Sreturn *) normalize nodelta #Heq
4892          @(eventually_now ????)
4893          whd in match (exec_step ??) in Heq ⊢ %;
4894          cases retval in Heq; normalize nodelta
4895          [ 1: >fn_return_simplify cases (fn_return f) normalize nodelta
4896               whd in match (ret ??) in ⊢ (% → %);
4897               [ 2: #sz #sg | 3: #fl | 4: #rg #ty' | 5: #rg #ty #n | 6: #tl #ty'
4898               | 7: #id #fl | 8: #id #fl | 9: #rg #id ]
4899               #H destruct (H)
4900               %{(Returnstate Vundef (call_cont k') (free_list m (blocks_of_env e)))}
4901               @conj [ 1: // | 2: %3 @call_cont_swremoval // ]
4902          | 2: #expr >fn_return_simplify cases (type_eq_dec (fn_return f) Tvoid) normalize nodelta
4903               [ 1: #_ #Habsurd destruct (Habsurd)
4904               | 2: #_ elim (Hexpr_related expr)
4905                    [ 2: * #error #Hfail >Hfail #Habsurd normalize in Habsurd; destruct (Habsurd)
4906                    | 1: cases (exec_expr ??? expr)
4907                         [ 2: #error #_ #Habsurd normalize in Habsurd; destruct (Habsurd)
4908                         | 1: #a #Hsim lapply (Hsim a (refl ? (OK ? a)))
4909                              #Hrewrite >Hrewrite
4910                              whd in match (m_bind ?????); whd in match (m_bind ?????);
4911                              #Heq destruct (Heq)
4912                              %{(Returnstate (\fst  a) (call_cont k') (free_list m (blocks_of_env e)))}
4913                              @conj [ 1: // | 2: %3 @call_cont_swremoval // ]
4914         ] ] ] ]
4915    | 12: (* Sswitch. Main proof case. *) normalize nodelta
4916          (* Case analysis on the outcome of the tested expression *)
4917          cases (exec_expr_int ge e m cond)
4918          [ 2: cases (exec_expr ge e m cond)
4919               [ 2: #error whd in match (m_bind ?????); #_ #Habsurd destruct (Habsurd)
4920               | 1: * #val #trace cases val
4921                    [ 1: | 2: #condsz #condv | 3: #condf | 4: #condrg | 5: #condptr ]
4922                    whd in match (m_bind ?????);
4923                    [ 1,3,4,5: #_ #Habsurd destruct (Habsurd)
4924                    | 2: #Habsurd lapply (Habsurd condsz condv trace) * #Hfalse @(False_ind … (Hfalse (refl ??))) ]  ]
4925          ]
4926          * #condsz * #condval * #condtr #Hexec_cond >Hexec_cond
4927          whd in match (m_bind ?????); #Heq
4928          destruct (Heq)
4929          @eventually_later
4930          whd in match (sw_rem (Sswitch cond switchcases) u);
4931          whd in match (switch_removal (Sswitch cond switchcases) u);
4932          elim (switch_removal_branches_eq switchcases u)
4933          #switchcases' * #new_vars * #uv1 #Hsrb_eq >Hsrb_eq normalize nodelta
4934          cut (uv1 = (\snd (switch_removal_branches switchcases u)))
4935          [ 1: >Hsrb_eq // ] #Huv1_eq
4936          cut (fresh_for_statement (Sswitch cond switchcases) uv1)
4937          [ 1: >Huv1_eq @switch_removal_branches_fresh assumption ] -Huv1_eq #Huv1_eq
4938          elim (fresh_eq … Huv1_eq) #switch_tmp * #uv2 * #Hfresh_eq >Hfresh_eq -Hfresh_eq #Huv2_eq normalize nodelta
4939          whd in match (simplify_switch ???);
4940          elim (fresh_eq … Huv2_eq) #exit_label * #uv3 * #Hfresh_eq >Hfresh_eq -Hfresh_eq #Huv3_eq normalize nodelta
4941          lapply (produce_cond_fresh (Expr (Evar switch_tmp) (typeof cond)) exit_label switchcases' uv3 (max_of_statement (Sswitch cond switchcases)) Huv3_eq)
4942          elim (produce_cond_eq (Expr (Evar switch_tmp) (typeof cond)) switchcases' uv3 exit_label)         
4943          #result * #top_label * #uv4 #Hproduce_cond_eq >Hproduce_cond_eq normalize nodelta
4944          #Huv4_eq
4945          whd in match (exec_step ??);
4946          %{(State (function_switch_removal f)
4947                   (Sassign (Expr (Evar switch_tmp) (typeof cond)) cond)
4948                   (Kseq (Ssequence result (Slabel exit_label Sskip)) k') e m)}
4949          %{E0} @conj try @refl
4950          %{tr} normalize in match (eq ???); @conj try //
4951          (* execute the conditional *)
4952          @eventually_later
4953          (* lift the result of the previous case analysis from [ge] to [ge'] *)
4954          whd in match (exec_step ??);
4955          whd in match (exec_lvalue ????);
4956         
4957          >(exec_expr_related … Hexec_cond (Hexpr_related cond))
4958         
4959  *)
4960 
Note: See TracBrowser for help on using the repository browser.