diff --git a/CHANGELOG.md b/CHANGELOG.md index 4189fea2d..2eea13847 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -16,6 +16,11 @@ `UMLAL`, `SMULL`, `SMLAL`, `SMMUL`, `SMMULR` ([PR #481](https://github.com/jasmin-lang/jasmin/pull/481)). +- Register arrays can appear as arguments and return values of local functions; + the “make-reference-arguments” pass is now run before expansion of register + arrays; + ([PR #452](https://github.com/jasmin-lang/jasmin/pull/452)). + ## Bug fixes - Type-checking rejects wrongly casted primitive operators diff --git a/compiler/src/compile.ml b/compiler/src/compile.ml index 3e2ab3852..01dea0c6e 100644 --- a/compiler/src/compile.ml +++ b/compiler/src/compile.ml @@ -133,7 +133,42 @@ let compile (type reg regx xreg rflag cond asm_op extra_op) :: !arrs in Hv.iter doarr harrs; - { Array_expansion.vars; arrs = !arrs } + + let f_cc = + match fd.f_cc with + | Subroutine si -> + (* Since some arguments/returns are expended we need to fix the info *) + let tbl = Hashtbl.create 17 in + let newpos = ref 0 in + let mk_n x = + match x.v_kind, x.v_ty with + | Reg (_, Direct), Arr (_, n) -> n + | _, _ -> 1 + in + let doarg i x = + Hashtbl.add tbl i !newpos; + newpos := !newpos + mk_n x + in + List.iteri doarg fd.f_args; + let doret o x = + match o with + | Some i -> [Some (Hashtbl.find tbl i)] + | None -> List.init (mk_n (L.unloc x)) (fun _ -> None) + in + let returned_params = + List.flatten (List.map2 doret si.returned_params fd.f_ret) in + FInfo.Subroutine { returned_params } + + | _ -> fd.f_cc + in + let do_outannot x a = + try + let (_, va) = Hv.find harrs (L.unloc x) in + List.init (Array.length va) (fun _ -> []) + with Not_found -> [a] in + let f_outannot = List.flatten (List.map2 do_outannot fd.f_ret fd.f_outannot) in + let finfo = fd.f_loc, fd.f_annot, f_cc, f_outannot in + { Array_expansion.vars; arrs = !arrs; finfo } in let refresh_instr_info fn f = diff --git a/compiler/src/evaluator.ml b/compiler/src/evaluator.ml index 1287791cf..689f85140 100644 --- a/compiler/src/evaluator.ml +++ b/compiler/src/evaluator.ml @@ -4,9 +4,10 @@ open Type open Sem_type open Warray_ open Var0 +open Varmap open Low_memory open Expr -open Sem +open Psem_defs open Values open Sem_params @@ -37,7 +38,7 @@ let of_val_b ii v : bool = type 'asm stack = | Sempty of instr_info * 'asm fundef | Scall of - instr_info * 'asm fundef * lval list * sem_t exec Fv.t * 'asm instr list * 'asm stack + instr_info * 'asm fundef * lval list * Vm.t * 'asm instr list * 'asm stack | Sfor of instr_info * var_i * coq_Z list * 'asm instr list * 'asm instr list * 'asm stack type ('syscall_state, 'asm) state = @@ -56,7 +57,7 @@ let return ep spp s = let s2 = s.s_estate in let m2 = s2.emem and vm2 = s2.evm in let vres = - exn_exec ii (mapM (fun (x:var_i) -> get_var vm2 x.v_var) f.f_res) in + exn_exec ii (mapM (fun (x:var_i) -> get_var nosubword true vm2 x.v_var) f.f_res) in let vres' = exn_exec ii (mapM2 ErrType truncate_val f.f_tyout vres) in raise (Final(m2, vres')) @@ -64,9 +65,9 @@ let return ep spp s = let gd = s.s_prog.p_globs in let {escs = scs2; emem = m2; evm = vm2} = s.s_estate in let vres = - exn_exec ii (mapM (fun (x:var_i) -> get_var vm2 x.v_var) f.f_res) in + exn_exec ii (mapM (fun (x:var_i) -> get_var nosubword true vm2 x.v_var) f.f_res) in let vres' = exn_exec ii (mapM2 ErrType truncate_val f.f_tyout vres) in - let s1 = exn_exec ii (write_lvals ep spp gd {escs = scs2; emem = m2; evm = vm1 } xs vres') in + let s1 = exn_exec ii (write_lvals nosubword ep spp true gd {escs = scs2; emem = m2; evm = vm1 } xs vres') in { s with s_cmd = c; s_estate = s1; @@ -76,7 +77,7 @@ let return ep spp s = match ws with | [] -> { s with s_cmd = c; s_stk = stk } | w::ws -> - let s1 = exn_exec ii (write_var ep i (Vint w) s.s_estate) in + let s1 = exn_exec ii (write_var nosubword ep true i (Vint w) s.s_estate) in { s with s_cmd = body; s_estate = s1; s_stk = Sfor(ii, i, ws, body, c, stk) } @@ -91,31 +92,30 @@ let small_step1 ep spp sip s = match ir with | Cassgn(x,_,ty,e) -> - let v = exn_exec ii (sem_pexpr ep spp gd s1 e) in + let v = exn_exec ii (sem_pexpr nosubword ep spp true gd s1 e) in let v' = exn_exec ii (truncate_val ty v) in - let s2 = exn_exec ii (write_lval ep spp gd x v' s1) in + let s2 = exn_exec ii (write_lval nosubword ep spp true gd x v' s1) in { s with s_cmd = c; s_estate = s2 } | Copn(xs,_,op,es) -> - let s2 = exn_exec ii (sem_sopn ep spp sip._asmop gd op s1 xs es) in + let s2 = exn_exec ii (sem_sopn nosubword ep spp sip._asmop gd op s1 xs es) in { s with s_cmd = c; s_estate = s2 } | Csyscall(xs,o, es) -> - let ves = exn_exec ii (sem_pexprs ep spp gd s1 es) in - let ((scs, m), vs) = - exn_exec ii (exec_syscall sip._sc_sem ep._pd s1.escs s1.emem o ves) - in - let s2 = exn_exec ii (write_lvals ep spp gd {escs = scs; emem = m; evm = s1.evm} xs vs) in + let ves = exn_exec ii (sem_pexprs nosubword ep spp true gd s1 es) in + let ((scs, m), vs) = + exn_exec ii (syscall_sem__ sip._sc_sem ep._pd s1.escs s1.emem o ves) in + let s2 = exn_exec ii (write_lvals nosubword ep spp true gd {escs = scs; emem = m; evm = s1.evm} xs vs) in { s with s_cmd = c; s_estate = s2 } | Cif(e,c1,c2) -> - let b = of_val_b ii (exn_exec ii (sem_pexpr ep spp gd s1 e)) in + let b = of_val_b ii (exn_exec ii (sem_pexpr nosubword ep spp true gd s1 e)) in let c = (if b then c1 else c2) @ c in { s with s_cmd = c } | Cfor (i,((d,lo),hi), body) -> - let vlo = of_val_z ii (exn_exec ii (sem_pexpr ep spp gd s1 lo)) in - let vhi = of_val_z ii (exn_exec ii (sem_pexpr ep spp gd s1 hi)) in + let vlo = of_val_z ii (exn_exec ii (sem_pexpr nosubword ep spp true gd s1 lo)) in + let vhi = of_val_z ii (exn_exec ii (sem_pexpr nosubword ep spp true gd s1 hi)) in let rng = wrange d vlo vhi in let s = {s with s_cmd = []; s_stk = Sfor(ii, i, rng, body, c, s.s_stk) } in @@ -125,7 +125,7 @@ let small_step1 ep spp sip s = { s with s_cmd = c1 @ MkI(ii, Cif(e, c2@[i],[])) :: c } | Ccall(_,xs,fn,es) -> - let vargs' = exn_exec ii (sem_pexprs ep spp gd s1 es) in + let vargs' = exn_exec ii (sem_pexprs nosubword ep spp true gd s1 es) in let f = match get_fundef s.s_prog.p_funcs fn with | Some f -> f @@ -134,7 +134,7 @@ let small_step1 ep spp sip s = let {escs; emem = m1; evm = vm1} = s1 in let stk = Scall(ii,f, xs, vm1, c, s.s_stk) in let sf = - exn_exec ii (write_vars ep f.f_params vargs {escs; emem = m1; evm = vmap0}) in + exn_exec ii (write_vars nosubword ep true f.f_params vargs {escs; emem = m1; evm = Vm.init nosubword}) in {s with s_cmd = f.f_body; s_estate = sf; s_stk = stk } @@ -144,10 +144,10 @@ let rec small_step ep spp sip s = small_step ep spp sip (small_step1 ep spp sip s) let init_state ep scs0 p ii fn args m = - let f = Option.get (get_fundef p.p_funcs fn) in + let f = BatOption.get (get_fundef p.p_funcs fn) in let vargs = exn_exec ii (mapM2 ErrType truncate_val f.f_tyin args) in - let s_estate = { escs = scs0; emem = m; evm = vmap0 } in - let s_estate = exn_exec ii (write_vars ep f.f_params vargs s_estate) in + let s_estate = { escs = scs0; emem = m; evm = Vm.init nosubword} in + let s_estate = exn_exec ii (write_vars nosubword ep true f.f_params vargs s_estate) in { s_prog = p; s_cmd = f.f_body; s_estate; s_stk = Sempty (ii, f) } diff --git a/compiler/tests/success/subroutines/x86-64/arr_exp.jazz b/compiler/tests/success/subroutines/x86-64/arr_exp.jazz new file mode 100644 index 000000000..e779550bb --- /dev/null +++ b/compiler/tests/success/subroutines/x86-64/arr_exp.jazz @@ -0,0 +1,20 @@ +fn test (reg u64[2] t) -> reg u64[2] { + inline int i; + for i = 0 to 2 { + t[i] += 1; + } + return t; +} + +export fn main () -> reg u64 { + reg u64[2] t; + reg u64 r; + inline int i; + for i = 0 to 2 { + t[i] = i; + } + t = test(t); + t[0] += t[1]; + r = t[0]; + return r; +} diff --git a/compiler/tests/success/subroutines/x86-64/arr_exp_finfo.jazz b/compiler/tests/success/subroutines/x86-64/arr_exp_finfo.jazz new file mode 100644 index 000000000..897fe1dd1 --- /dev/null +++ b/compiler/tests/success/subroutines/x86-64/arr_exp_finfo.jazz @@ -0,0 +1,63 @@ +fn test1 (reg u64[2] t, reg ptr u64[2] p) -> reg ptr u64[2], reg u64[2] { + inline int i; + for i = 0 to 2 { + t[i] += 1; + p[i] += 1; + } + + return p, t; +} + +fn test2 (reg u64[2] t, reg ptr u64[2] p) -> reg u64[2], reg ptr u64[2] { + inline int i; + for i = 0 to 2 { + t[i] += 1; + p[i] += 1; + } + + return t, p; +} + +fn test3 (reg ptr u64[2] p, reg u64[2] t) -> reg ptr u64[2], reg u64[2] { + inline int i; + for i = 0 to 2 { + t[i] += 1; + p[i] += 1; + } + + return p, t; +} + +fn test4 (reg ptr u64[2] p, reg u64[2] t) -> reg u64[2], reg ptr u64[2] { + inline int i; + for i = 0 to 2 { + t[i] += 1; + p[i] += 1; + } + + return t, p; +} + + + +export fn main () -> reg u64 { + stack u64[2] s; + reg u64[2] t; + reg ptr u64[2] p; + reg u64 r; + inline int i; + p = s; + for i = 0 to 2 { + t[i] = i; + p[i] = i; + } + p,t = test1(t,p); + t,p = test2(t,p); + p,t = test3(p,t); + t,p = test4(p,t); + t[0] += t[1]; + t[0] += p[0]; + t[0] += p[1]; + r = t[0]; + return r; +} diff --git a/proofs/_CoqProject b/proofs/_CoqProject index b4162ca4a..aeb6e523d 100644 --- a/proofs/_CoqProject +++ b/proofs/_CoqProject @@ -56,6 +56,7 @@ compiler/dead_calls.v compiler/dead_calls_proof.v compiler/dead_code.v compiler/dead_code_proof.v +compiler/direct_call_proof.v compiler/inline.v compiler/inline_proof.v compiler/jasmin_compiler.v @@ -110,11 +111,11 @@ lang/lowering_lemmas.v lang/memory_example.v lang/memory_model.v lang/one_varmap.v -lang/psem_of_sem_proof.v -lang/psem_facts.v lang/psem.v +lang/psem_defs.v +lang/psem_of_sem_proof.v lang/pseudo_operator.v -lang/sem.v +lang/psem_facts.v lang/sem_one_varmap.v lang/sem_op_typed.v lang/sem_one_varmap_facts.v @@ -131,6 +132,7 @@ lang/type.v lang/utils.v lang/values.v lang/var.v +lang/varmap.v lang/waes.v lang/warray_.v lang/word.v diff --git a/proofs/arch/asm_gen_proof.v b/proofs/arch/asm_gen_proof.v index 826d3b209..feeb815a7 100644 --- a/proofs/arch/asm_gen_proof.v +++ b/proofs/arch/asm_gen_proof.v @@ -26,6 +26,8 @@ Unset Printing Implicit Defensive. Section ASM_EXTRA. +#[local] Existing Instance withsubword. + Context {syscall_state : Type} {sc_sem : syscall_sem syscall_state} `{asm_e : asm_extra} {call_conv: calling_convention} {asm_scsem : asm_syscall_sem}. @@ -52,7 +54,7 @@ Definition of_rbool (v : rflagv) := (* -------------------------------------------------------------------- *) Definition eqflags (m: estate) (rf: rflagmap) : Prop := - ∀ (f: rflag) v, on_vu Vbool (ok undef_b) (evm m).[to_var f]%vmap = ok v → value_uincl v (of_rbool (rf f)). + ∀ (f: rflag), value_uincl (evm m).[to_var f] (of_rbool (rf f)). Variant disj_rip rip := | Drip of @@ -65,11 +67,11 @@ Variant lom_eqv rip (m : estate) (lom : asmmem) := | MEqv of escs m = asm_scs lom & emem m = asm_mem lom - & get_var (evm m) rip = ok (Vword lom.(asm_rip)) + & (evm m).[rip] = Vword lom.(asm_rip) & disj_rip rip - & (∀ r v, get_var (evm m) (to_var r) = ok v → value_uincl v (Vword (asm_reg lom r))) - & (∀ r v, get_var (evm m) (to_var r) = ok v → value_uincl v (Vword (asm_regx lom r))) - & (∀ r v, get_var (evm m) (to_var r) = ok v → value_uincl v (Vword (asm_xreg lom r))) + & (∀ r, value_uincl (evm m).[to_var r] (Vword (asm_reg lom r))) + & (∀ r, value_uincl (evm m).[to_var r] (Vword (asm_regx lom r))) + & (∀ r, value_uincl (evm m).[to_var r] (Vword (asm_xreg lom r))) & eqflags m (asm_flag lom). (* -------------------------------------------------------------------- *) @@ -117,56 +119,87 @@ Lemma value_of_bool_to_bool_of_rbool x : Proof. by case: x. Qed. (* -------------------------------------------------------------------- *) -Lemma xgetreg_ex rip x r v s xs : +Lemma getreg wdb rip r v s xs : + lom_eqv rip s xs → + get_var wdb s.(evm) (to_var r) = ok v → + value_uincl v (Vword (xs.(asm_reg) r)). +Proof. by case => _ _ _ _ eqv _ _ _ /get_varP [-> _ _]. Qed. + +Lemma ofgetreg wdb rip x r v s xs : lom_eqv rip s xs → of_var x = Some r → - get_var s.(evm) x = ok v → + get_var wdb s.(evm) x = ok v → value_uincl v (Vword (xs.(asm_reg) r)). -Proof. case => _ _ _ _ eqv _ _ _ h; have <- := of_varI h; exact: eqv. Qed. +Proof. move=> lom h; have <- := of_varI h; apply: getreg lom. Qed. (* -------------------------------------------------------------------- *) -Lemma xgetregx_ex rip x r v s xs : +Lemma getregx wdb rip r v s xs : + lom_eqv rip s xs → + get_var wdb s.(evm) (to_var r) = ok v → + value_uincl v (Vword (xs.(asm_regx) r)). +Proof. by case => _ _ _ _ _ eqv' _ _ /get_varP [-> _ _]. Qed. + +Lemma ofgetregx wdb rip x r v s xs : lom_eqv rip s xs → of_var x = Some r → - get_var s.(evm) x = ok v → + get_var wdb s.(evm) x = ok v → value_uincl v (Vword (xs.(asm_regx) r)). -Proof. case => _ _ _ _ eqv eqv' eqv'' _ h; have <- := of_varI h;exact: eqv'. Qed. +Proof. move=> lom h; have <- := of_varI h; apply: getregx lom. Qed. (* -------------------------------------------------------------------- *) -Lemma xxgetreg_ex rip x r v s xs : +Lemma getxreg wdb rip r v s xs : + lom_eqv rip s xs → + get_var wdb (evm s) (to_var r) = ok v → + value_uincl v (Vword (asm_xreg xs r)). +Proof. by case => _ _ _ _ _ _ eqv _ /get_varP [-> _ _]. Qed. + +Lemma ofgetxreg wdb rip x r v s xs : lom_eqv rip s xs → of_var x = Some r → - get_var (evm s) x = ok v → + get_var wdb (evm s) x = ok v → value_uincl v (Vword (asm_xreg xs r)). -Proof. by case => _ _ _ _ _ _ eqv _ h; have <- := of_varI h; exact: eqv. Qed. +Proof. move=> lom h; have <- := of_varI h; apply: getxreg lom. Qed. (* -------------------------------------------------------------------- *) -Lemma xgetflag_ex ii m rf x f v : + +Lemma getflag wdb rip f v s xs : + lom_eqv rip s xs → + get_var wdb (evm s) (to_var f) = ok v → + value_uincl v (of_rbool (asm_flag xs f)). +Proof. by case => _ _ _ _ _ _ _ eqf /get_varP [-> _ _]. Qed. + +Lemma ofgetflag wdb rip x f v s xs : + lom_eqv rip s xs → + of_var x = Some f → + get_var wdb (evm s) x = ok v → + value_uincl v (of_rbool (asm_flag xs f)). +Proof. move=> lom h; have <- := of_varI h; apply: getflag lom. Qed. + +Lemma xgetflag_ex wdb ii m rf x f v : eqflags m rf → of_var_e ii x = ok f → - get_var (evm m) x = ok v → + get_var wdb (evm m) x = ok v → value_uincl v (of_rbool (rf f)). -Proof. - move => eqm /of_var_eP h; have <- := of_varI h. - rewrite get_varE; t_xrbindP => /= b ok_b <-. - move: (eqm f b). - by rewrite ok_b => /(_ erefl). -Qed. +Proof. move => eqm /of_var_eP h; have <- := of_varI h => /get_varP [-> _ _]; apply eqm. Qed. -Corollary xgetflag ii m rf x f v b : +Corollary xgetflag wdb ii m rf x f v b : eqflags m rf → of_var_e ii x = ok f → - get_var (evm m) x = ok v → + get_var wdb (evm m) x = ok v → to_bool v = ok b → rf f = Def b. Proof. -move => eqm ok_f ok_v ok_b. -have := xgetflag_ex eqm ok_f ok_v. -case: {ok_v} v ok_b => //. -- by move => b' [<-]; case: (rf _) => // ? ->. -by case. +move => eqm ok_f ok_v /to_boolI ?; subst v. +by have /value_uinclE := xgetflag_ex eqm ok_f ok_v; case: (rf _) => //= ? [] <-. Qed. + +(* -------------------------------------------------------------------- *) +Lemma lom_rip wdb rip s xs : + lom_eqv rip s xs → + get_var wdb (evm s) rip = ok (Vword (asm_rip xs)). +Proof. by rewrite /get_var orbC => -[_ _ -> *] /=. Qed. + (* -------------------------------------------------------------------- *) Context @@ -197,7 +230,7 @@ Lemma assemble_leaP rip ii sz sz' (w:word sz') lea adr m s: assemble_lea ii lea = ok adr → zero_extend sz (decode_addr s adr) = zero_extend sz w. Proof. - move=> hsz64 hsz [_ _ _ _ hget _ _ _] hsem; rewrite /assemble_lea. + move=> hsz64 hsz lom hsem; rewrite /assemble_lea. t_xrbindP => ob hob oo hoo sc hsc <- /=. rewrite /decode_reg_addr /=. move: hsem; rewrite /sem_lea. @@ -207,12 +240,12 @@ Proof. congr (_ + _ + _ * _)%R. + by rewrite zero_extend_wrepr. + case: lea_base hob hwb => /= [vo | [<-] [<-] /=]; last by apply zero_extend0. - by t_xrbindP => r /of_var_eI <- <- v /hget /[swap] - /to_wordI [? [? [-> /word_uincl_truncate h]]] /= /h /truncate_wordP []. + t_xrbindP => r /of_var_eP h <- v /= /(ofgetreg lom h) + h1. + by have [? [? [-> /word_uincl_truncate h2 /h2 /truncate_wordP []]]] := to_wordI h1. + by rewrite -(xscale_ok hsc). case: lea_offset hoo hwo => /= [vo | [<-] [<-] /=]; last by apply zero_extend0. - by t_xrbindP => r /of_var_eI <- <- v /hget /[swap] - /to_wordI [? [? [-> /word_uincl_truncate h]]] /= /h /truncate_wordP []. + t_xrbindP => r /of_var_eP h <- v /= /(ofgetreg lom h) + h1. + by have [? [? [-> /word_uincl_truncate h2 /h2 /truncate_wordP []]]] := to_wordI h1. Qed. Lemma addr_of_fexprP rip ii sz sz' (w: word sz') e adr m s: @@ -230,17 +263,14 @@ Proof. case: eqP => [ | _]; last by apply (assemble_leaP hsz64 hsz lom hsemlea). t_xrbindP => hbrip. case ho: lea_offset => [ // | ] _ <- /=. - case: lom => _ _ hrip _ _ _. - move: hsemlea; rewrite /sem_lea ho hb /= hbrip hrip /= truncate_word_le // /= => h. - have <- := ok_inj h. - move => _ _. + move: hsemlea; rewrite /sem_lea ho hb /= hbrip (lom_rip _ lom) /= truncate_word_le //= => /ok_inj <-. by rewrite GRing.mulr0 GRing.addr0 GRing.addrC wadd_zero_extend // zero_extend_wrepr. Qed. Lemma addr_of_xpexprP rip m s ii x p r vx wx vp wp: lom_eqv rip m s → addr_of_xpexpr rip ii Uptr x p = ok r -> - get_var (evm m) x = ok vx -> + get_var true (evm m) x = ok vx -> to_pointer vx = ok wx -> sem_fexpr m.(evm) p = ok vp -> to_pointer vp = ok wp -> @@ -277,35 +307,34 @@ Qed. Lemma var_of_flagP rip m s f v ty vt: lom_eqv rip m s - -> get_var (evm m) (to_var f) = ok v + -> get_var true (evm m) (to_var f) = ok v -> of_val ty v = ok vt -> exists2 v' : value, Let b := st_get_rflag s f in ok (Vbool b) = ok v' & of_val ty v' = ok vt. Proof. - move=> [_ _ _ _ _ _ _ h]. - rewrite get_varE; t_xrbindP => /= b ok_b <-{v} /of_valE[? ]; subst=> /= ->. - move: (h f b); rewrite ok_b => /(_ erefl). - rewrite /st_get_rflag. - by case: (asm_flag s f) => // _ <-; exists b. + move=> lom h; rewrite /st_get_rflag. + have [b ?]:= get_varE h; subst v. + have /value_uinclE <- := getflag lom h. + move=> /of_valE; case: (asm_flag s f) => //= ?[]? <-; subst => /=; eauto. Qed. Lemma var_of_regP rip E m s r v ty vt: lom_eqv rip m s - -> get_var (evm m) (to_var r) = ok v + -> get_var true (evm m) (to_var r) = ok v -> of_val ty v = ok vt -> exists2 v' : value, Ok E (Vword ((asm_reg s) r)) = ok v' & of_val ty v' = ok vt. -Proof. by move=> [???? h ???] /h /of_value_uincl h1 /h1 <-; eauto. Qed. +Proof. move=> lom /(getreg lom) hg /(of_value_uincl hg) <-; eauto. Qed. Lemma var_of_regP_eq rip m s (r:reg_t) v vt: lom_eqv rip m s - -> get_var (evm m) (to_var r) = ok v + -> get_var true (evm m) (to_var r) = ok v -> to_pointer v = ok vt -> asm_reg s r = vt. Proof. - move=> [???? h ???] /h /of_value_uincl h1 /(h1 (sword Uptr)) /=. + move=> lom /(getreg lom) /of_value_uincl h1 /(h1 (sword Uptr)) /=. by rewrite truncate_word_u => -[]. Qed. @@ -374,14 +403,14 @@ Proof. have -> := addr_of_xpexprP eqm hr hget htop hp hp'. by case: eqm => ? <- ?????; rewrite hwr /=; eauto. case => //. - + case: eqm => _ _ _ _ eqr eqrx eqx _ x. + + move=> x. move=> /xreg_of_varI; case: a' hcomp => // r; rewrite /compat_imm orbF => /eqP <- {a} h; have /= <- := of_varI h => w ok_v /to_wordI[? [? [? ok_w]]]; (eexists; first reflexivity); apply: (word_uincl_truncate _ ok_w); subst. - + exact: (eqr _ _ ok_v). - + exact: (eqrx _ _ ok_v). - exact: (eqx _ _ ok_v). + + exact: getreg eqm ok_v. + + exact: getregx eqm ok_v. + exact: getxreg eqm ok_v. case => //= w' [] //= z. t_xrbindP => /eqP _ h; move: hcomp; rewrite -h /compat_imm /eval_asm_arg => -/orP [/eqP <- | ]. + move=> w [] <- /truncate_wordP [hsz ->]. @@ -431,29 +460,52 @@ Proof. by rewrite wandC wand0 wxor0. Qed. -Lemma lom_eqv_write_reg rip msbf (r : reg) s xs ws ws0 (w : word ws0) : +Lemma lom_eqv_write_var f rip s xs (x : var_i) sz (w : word sz) s' r : + lom_eqv rip s xs + -> write_var true x (Vword w) s = ok s' + -> to_var r = x + -> lom_eqv rip s' (mem_write_reg f r w xs). +Proof. + case => eqscs eqm ok_rip [dr drx dx df] eqr eqrx eqx eqf. + case: x => x xi /=. + rewrite /mem_write_reg => /write_varP [-> hdb htr] ?; subst x. + constructor => //=. + + by rewrite Vm.setP_neq //; apply /eqP. + + move=> r'; rewrite Vm.setP /RegMap.set ffunE eq_sym. + have -> : (to_var r' == to_var r) = (r' == r ::>). + + by apply/eqtype.inj_eq/inj_to_var. + case: eqP => [<- /= | hne]; last by apply eqr. + case: ifPn => hsz /=. + + by apply word_uincl_word_extend => //; apply cmp_lt_le. + by rewrite word_extend_big //;apply /negP. + + move=> r'; rewrite Vm.setP_neq; first by apply eqrx. + by apply/eqP/to_var_reg_neq_regx. + + move=> r'; rewrite Vm.setP_neq; first by apply eqx. + by apply/eqP/to_var_reg_neq_xreg. + by move=> ?; rewrite Vm.setP_neq. +Qed. + +Lemma lom_eqv_write_reg rip msbf r s xs ws ws0 (w : word ws0) : lom_eqv rip s xs -> (ws0 = ws \/ msbf = MSB_CLEAR) -> - let: pw := to_pword reg_size (Vword (zero_extend ws w)) in lom_eqv rip - (with_vm s (evm s).[to_var r <- pw]%vmap) + (with_vm s (evm s).[to_var r <- Vword (zero_extend ws w)]) (mem_write_reg msbf r w xs). Proof. move=> [hscs h1 hrip hnrip h2 h3 h4 h5] h. constructor => //=. - - rewrite /get_var Fv.setP_neq //. apply/eqP. by move: hnrip => []. + - rewrite /get_var Vm.setP_neq //. apply/eqP. by move: hnrip => []. - - move=> r' v. - rewrite /get_var /on_vu /= /RegMap.set ffunE. + - move=> r'. + rewrite /RegMap.set ffunE. case: eqP => [-> | hne]. - + rewrite Fv.setP_eq => -[<-] /=. - case: h => h; - subst; + + rewrite Vm.setP_eq => /=. + case: h => h; subst; first rewrite zero_extend_u; last rewrite word_extend_CLEAR; - case: Sumbool.sumbool_of_bool => /= hsz. + case: ifP => /= hsz. * exact: word_uincl_word_extend. * by rewrite word_extend_big // hsz. * rewrite -(zero_extend_idem _ hsz). exact: (word_uincl_zero_ext _ hsz). @@ -461,25 +513,19 @@ Proof. apply: cmp_lt_le. by rewrite -cmp_nle_lt hsz. - rewrite Fv.setP_neq; first exact: h2. + rewrite Vm.setP_neq; first exact: h2. apply/eqP => ?. apply hne. exact: inj_to_var. - - move=> r' v. - rewrite get_var_neq; first exact: h3. - rewrite /to_var /= /rtype /=. - move=> []. + - move=> r'. + rewrite Vm.setP_neq; first exact: h3. + rewrite /to_var /= /rtype /=; apply/eqP => -[]. exact: inj_toI_reg_regx. - - move=> r' v. - rewrite get_var_neq; last by apply to_var_reg_neq_xreg. - exact: h4. + - move=> r'; rewrite Vm.setP_neq //; apply/eqP; apply to_var_reg_neq_xreg. - move=> f v. - rewrite /get_var /on_vu /=. - rewrite Fv.setP_neq //. - exact: h5. + by move=> f; rewrite Vm.setP_neq. Qed. Lemma compile_lval rip ii msb_flag loargs ad ty (vt:sem_ot ty) m m' s lv1 e1: @@ -494,99 +540,71 @@ Proof. case: ai => [f | r]. + case: lv1 => //=; first by move=> ???? <-. t_xrbindP => x vm hvm <- <- /is_implicitP[] xi [] ?; subst x. - move: hvm; rewrite /mem_write_val /set_var /on_vu /= /oof_val. - case: ty vt => //= vt h. - have -> : + case: ty vt hvm => //= vt /set_varP [_ htr ->]; rewrite /mem_write_val /=. + have -> /= : match match vt with Some b => Vbool b | None => undef_b end with | Vbool b => ok (Some b) | Vundef sbool _ => ok None | _ => type_error end = ok vt. - + by case: vt h. - have -> /= : vm = ((evm m).[to_var (tS:=toS_f) f <- match vt with Some b => ok b | None => undef_error end])%vmap. - + by case: vt h => [b | ] /= [<-]. + + by case: vt htr. eexists; split; first reflexivity. constructor => //=. - + by case:hlom => ? ? hget hd _ _ _;rewrite /get_var Fv.setP_neq //; apply /eqP;case: hd. - + move=> r v; rewrite /get_var /=; apply on_vuP => //= w. - rewrite Fv.setP_neq // => hg hv. - by apply (h2 r); rewrite /get_var /on_vu hg -hv. - + move=> r v; rewrite /get_var /=; apply on_vuP => //= w. - rewrite Fv.setP_neq // => hg hv. - by apply (h3 r); rewrite /get_var /on_vu hg -hv. - + move=> r v; rewrite /get_var /=; apply on_vuP => //= w. - rewrite Fv.setP_neq // => hg hv. - by apply (h4 r); rewrite /get_var /on_vu hg -hv. - rewrite /eqflags => f' v; rewrite /get_var /on_vu /=. - rewrite /RflagMap.set /= ffunE. - case: eqP => [-> | hne] {h}. - + by rewrite Fv.setP_eq; case: vt => [ b | ] /ok_inj <-. - rewrite Fv.setP_neq; first by apply h5. - by apply /eqP => h; apply hne; apply: inj_to_var. + + by case:hlom => ? ? hget hd _ _ _; rewrite Vm.setP_neq //; apply/eqP; case: hd. + 1-3: by move=> r; rewrite Vm.setP_neq. + move=> f'; rewrite /RflagMap.set /= ffunE Vm.setP eq_sym. + have -> : (to_var f' == to_var f) = (f' == f ::>). + + by apply/eqtype.inj_eq/inj_to_var. + case: eqP => [<- | hne] //. + by move: (vm_truncate_valE htr) => {htr}; case: vt => [ b | ] [+ ->]. + case: lv1 => //=; first by move=> ???? <-. - t_xrbindP => x vm hvm <- <- /is_implicitP[] xi [] ?; subst x. - case: ty vt hvm => //; first by case. - move => sz w [] <- {vm}. - rewrite /mem_write_val /= truncate_word_u. - eexists; split; first reflexivity. - rewrite -/(to_pword _ (Vword _)) -{1}(zero_extend_u w). - apply: (lom_eqv_write_reg _ _ hlom). - by left. - + move=> x hw <- /is_implicitP [] xi [] ?; subst x. + case: ty vt hw=> //; first by case. + move=> ws vt hw. + have /(_ r erefl) := lom_eqv_write_var msb_flag hlom hw. + rewrite /mem_write_val /= truncate_word_u /=; eauto. case heq1: onth => [a | //]. case heq2: arg_of_rexpr => [ a' | //] hty hw he1 /andP[] /eqP ? hc; subst a'. - rewrite /mem_write_val /= /mem_write_ty. + rewrite /mem_write_val /mem_write_ty. case: lv1 hw he1 heq2=> //=; cycle 1. - + move=> [x xii] /= hw <-; rewrite /arg_of_rexpr. - case: ty hty vt hw => //= sz _ vt. - rewrite /write_var; t_xrbindP => vm hset <-. - apply: set_varP hset; last by move=> /eqP heq heq'; rewrite heq in heq'. - move=> t ht <-; rewrite truncate_word_u /= heq1 hc /= => /xreg_of_varI. - case: a heq1 hc => // r heq1 hc h; have {h}/=h := of_varI h; subst x; - (eexists; split; first reflexivity); constructor=> //=. - 2-5, 7-10, 12-15: move => r' v'. - 1-15: rewrite /get_var/on_vu. - 1, 14, 15: rewrite Fv.setP_neq; first exact: hrip; by apply/eqP; case: hnrip. - 1: rewrite /RegMap.set ffunE; case: eqP. - * move => ->{r'}; rewrite Fv.setP_eq => -[<-]{v'}. - case: ht => <-{t}; case: Sumbool.sumbool_of_bool => hsz /=. - + by apply word_uincl_word_extend. - by rewrite word_extend_big // hsz. - * move => hne; rewrite Fv.setP_neq; first exact: h2. - by apply/eqP => h; have ?:= inj_to_var h; apply: hne. - 1,2,3,4, 6-9, 11: rewrite Fv.setP_neq //. - 2, 4, 7, 9, 12, 14: rewrite eq_sym. - 1: exact: h3. - 1: rewrite /to_var /= /rtype /=; apply /eqP; move=> []. apply nesym. - exact: inj_toI_reg_regx. - 1: apply /eqP. apply nesym. by apply to_var_reg_neq_xreg. - 1: rewrite /to_var /= /rtype /=; apply /eqP; move=> []. - exact: inj_toI_reg_regx. - 1: rewrite eq_sym; by apply /eqP /to_var_regx_neq_xreg. - 1: apply /eqP. by apply /to_var_reg_neq_xreg. - 1: by apply /eqP /to_var_regx_neq_xreg. - 1: exact: h4. - 1: exact: h5. - 1: exact: h2. - 1: exact: h4. - 1: exact: h5. - 1: exact: h2. - 1: exact: h3. - 1: exact: h5. - 1: rewrite /XRegMap.set ffunE; case: eqP. - + move => ->{r'}. rewrite Fv.setP_eq => -[<-]{v'}. - case: ht => <-. - case : Sumbool.sumbool_of_bool => /= hsz; first by apply word_uincl_word_extend. - by rewrite word_extend_big // hsz. - move => hne; rewrite Fv.setP_neq; first exact: h3. - apply/eqP => h; have ? := inj_to_var h; exact: hne. - rewrite /XRegMap.set ffunE; case: eqP. - + move => ->{r'}; rewrite Fv.setP_eq => -[<-]{v'}. - case: ht => <-. - case : Sumbool.sumbool_of_bool => /= hsz; first by apply word_uincl_word_extend. - by rewrite word_extend_big // hsz. - move => hne; rewrite Fv.setP_neq; first exact: h4. - apply/eqP => h; have ? := inj_to_var h; exact: hne. + + move=> [x xii] hw <-; rewrite /arg_of_rexpr. + case: ty hty vt hw => //= sz _ vt hw. + rewrite truncate_word_u /= heq1 hc => /xreg_of_varI {heq1 hc}. + case: a => // r h; have {h}/=h := of_varI h; subst x. + + have hw' : write_var true {| v_var := to_var r; v_info := xii|} (Vword vt) m = ok m' by done. + have /(_ r erefl) := lom_eqv_write_var msb_flag hlom hw'; eauto. + + move: hw; t_xrbindP => vm /set_varP [_ htr ->] <-. + eexists; split; first reflexivity. + constructor => //=. + + by case:hlom => ? ? hget hd _ _ _ _;rewrite Vm.setP_neq //; apply/eqP; case: hd. + + move=> r'; rewrite Vm.setP_neq //. + by apply/eqP/nesym/to_var_reg_neq_regx. + + move=> r'; rewrite Vm.setP /RegMap.set ffunE eq_sym. + have -> : (to_var r' == to_var r) = (r' == r ::>). + + by apply/eqtype.inj_eq/inj_to_var. + case: eqP => [<- /= | hne]; last by apply h3. + case: ifPn => hsz /=. + + by apply word_uincl_word_extend => //; apply cmp_lt_le. + by rewrite word_extend_big //;apply /negP. + + move=> r'; rewrite Vm.setP_neq //. + by apply/eqP/to_var_regx_neq_xreg. + by move=> f; rewrite Vm.setP_neq. + move: hw; t_xrbindP => vm /set_varP [_ htr ->] <-. + eexists; split; first reflexivity. + constructor => //=. + + by case:hlom => ? ? hget hd _ _ _ _;rewrite Vm.setP_neq //; apply /eqP; case: hd. + + move=> r'; rewrite Vm.setP_neq //. + by apply/eqP/nesym/to_var_reg_neq_xreg. + + move=> r'; rewrite Vm.setP_neq //. + by apply/eqP/nesym/to_var_regx_neq_xreg. + + move=> r'; rewrite Vm.setP /RegMap.set ffunE eq_sym. + have -> : (to_var r' == to_var r) = (r' == r ::>). + + by apply/eqtype.inj_eq/inj_to_var. + case: eqP => [<- /= | hne]; last by apply h4. + case: ifPn => hsz /=. + + by apply word_uincl_word_extend => //; apply cmp_lt_le. + by rewrite word_extend_big //;apply /negP. + by move=> f; rewrite Vm.setP_neq. move=> sz [x xii] /= e; t_xrbindP. move=> wp vp hget hp wofs vofs he hofs w hw m1 hm1 ??; subst m' e1. case: ty hty vt hw => //= sz' _ vt hw. @@ -1251,9 +1269,9 @@ Proof. case: e => //; last case => //=; t_xrbindP; last first. - move => x _ /xreg_of_varI h ok_v. case: a h => // r ok_r; (eexists; first reflexivity). - + exact: (xgetreg_ex eqm ok_r ok_v). - + exact: (xgetregx_ex eqm ok_r ok_v). - exact: (xxgetreg_ex eqm ok_r ok_v). + + exact: (ofgetreg eqm ok_r ok_v). + + exact: (ofgetregx eqm ok_r ok_v). + exact: (ofgetxreg eqm ok_r ok_v). move => sz' ? ? _ /=; t_xrbindP => /eqP <-{sz'} d ok_d <- ptr w ok_w ok_ptr uptr u ok_u ok_uptr ? ok_rd ?; subst v => /=. case: (eqm) => _ eqmem _ _ _ _ _. rewrite (addr_of_xpexprP eqm ok_d ok_w ok_ptr ok_u ok_uptr) -eqmem ok_rd. @@ -1329,37 +1347,6 @@ Proof. by exists fd'. Qed. -Lemma lom_eqv_write_var f rip s xs (x : var_i) sz (w : word sz) s' r : - lom_eqv rip s xs - -> write_var x (Vword w) s = ok s' - -> to_var r = x - -> lom_eqv rip s' (mem_write_reg f r w xs). -Proof. - case => eqscs eqm ok_rip [dr drx dx df] eqr eqrx eqx eqf. - rewrite /mem_write_reg /write_var; t_xrbindP. - case: s' => scs m _ vm ok_vm [] <- <- <- hx. - constructor => //=. - - 2-5: move=> r' v'. - 1-4: rewrite (get_var_set_var _ ok_vm) -hx. - - - by move: dr => /(_ r) /eqP /negbTE ->. - - - rewrite /RegMap.set ffunE. - case: eqP => h; last first. - + case: eqP => [ ? | _ ]; last exact: eqr. - by elim h; congr to_var. - have -> := inj_to_var h; rewrite eqxx; t_xrbindP => /= w' ok_w' <- /=. - case: Sumbool.sumbool_of_bool ok_w' => hsz [] <-{w'} /=. - + by apply word_uincl_word_extend. - by rewrite word_extend_big // hsz. - - - have /eqP/negbTE-> := to_var_reg_neq_regx (atoI := _atoI) (r := r) (x := r'); apply: eqrx. - - by have /eqP/negbTE-> := to_var_reg_neq_xreg (atoI := _atoI) (r := r) (x := r'); apply: eqx. - - - by rewrite /= (get_set_var _ ok_vm) -hx /= => /eqf. -Qed. - Variant match_state (rip : var) (ls : lstate) (lc : lcmd) (xs : asm_state) : Prop := | MS @@ -1382,12 +1369,6 @@ Proof. move: (to_var _) (sv_of_list _ _); SvD.fsetdec. Qed. -Lemma get_var_eq_except vm1 vm2 x X : - ~Sv.In x X -> - vm1 = vm2 [\X] -> - get_var vm1 x = get_var vm2 x. -Proof. by rewrite /get_var => hnin -> //. Qed. - Lemma get_lvar_to_lvals xs : mapM get_lvar (to_lvals xs) = ok xs. Proof. by elim : xs => //= ?? ->. Qed. @@ -1635,41 +1616,42 @@ Proof. + move: hves => {vs hw ho}; elim: (take (size (syscall_sig_s o).(scs_tin)) call_reg_args) ves => [ | r rs ih] /= _vs. + by move=> [<-]. t_xrbindP => v hv vs /ih ? <-; constructor => //. - by case: hloeq => _ _ _ _ /(_ _ _ hv). + by apply : getreg hloeq hv. move=> [???]; subst scs m vs; split => //=; last by apply: asm_pos_incr ok_i hac heq hip. rewrite to_estate_of_estate. case: hloeq => /= hscs hmem hgetrip hdisjrip hreg hregx hxreg hflag. set R := vrvs (to_lvals (syscall_sig o).(scs_vout)). set X := Sv.union syscall_kill R. - have heqx: evm s = lvm ls [\ X]. - + rewrite /X; apply: (vmap_eq_exceptT (vm2 := vm_after_syscall (lvm ls))). - + apply: vmap_eq_exceptI; last by apply vmap_eq_exceptS; apply: vrvsP hw. + have heqx: evm s =[\X] lvm ls. + + rewrite /X; apply: (eq_exT (vm2 := vm_after_syscall (lvm ls))). + + apply: eq_exI; last by apply eq_exS; apply: vrvsP hw. by rewrite /=; SvD.fsetdec. - apply: (vmap_eq_exceptI (s1:= syscall_kill)); first SvD.fsetdec. + apply: (eq_exI (s2:= syscall_kill)); first SvD.fsetdec. by move=> z /Sv_memP/negPf hz; rewrite /vm_after_syscall kill_varsE hz. have hinj : injective (to_var (T:= reg_t)) by move=> ??; apply: inj_to_var. - have hres: forall r v, Sv.In (to_var r) R -> - get_var (evm s) (to_var r) = ok v -> value_uincl v (Vword (asm_reg xs' r)). - + move=> r v; rewrite /R vrvs_to_lvals => /sv_of_listP; rewrite mem_map //. + have hres: forall r, Sv.In (to_var r) R -> value_uincl (evm s).[to_var r] (Vword (asm_reg xs' r)). + + move=> r; rewrite /R vrvs_to_lvals => /sv_of_listP; rewrite mem_map //. assert (h := take_uniq (size (syscall_sig_s o).(scs_tout)) call_reg_ret_uniq). - move: hw r v. + move: hw r. elim: (take (size (syscall_sig_s o).(scs_tout)) call_reg_ret) {ho} - {| evm := (vm_after_syscall (lvm ls)) |} h => //= r rs ih s1 /andP [hnin huniq]. - rewrite (sumbool_of_boolET (cmp_le_refl reg_size)) => hw r0 v. + {| evm := (vm_after_syscall (lvm ls)) |} h => //= r rs ih s1 /andP [hnin huniq] hw r0. rewrite (in_cons (T:= @ceqT_eqType _ _)) => /orP []; last by apply: (ih _ huniq hw). - move=> /eqP ?; subst r0; rewrite -(get_var_eq_except _ (vrvsP (spp:=mk_spp) hw));last first. + move=> /eqP ?; subst r0. + have h: ¬ Sv.In (to_var r) (vrvs (to_lvals [seq to_var i | i <- rs])). + rewrite vrvs_to_lvals => /sv_of_listP /(mapP (T1:= @ceqT_eqType _ _)) [r'] hr' h. have ? := inj_to_var h; subst r'. by rewrite hr' in hnin. - rewrite /get_var /= Fv.setP_eq => -[] <-; apply value_uincl_refl. + have [<-]:= get_var_eq_ex false h (vrvsP (spp:=mk_spp) hw). + by rewrite Vm.setP_eq /= cmp_le_refl. have hkill : forall x, Sv.In x syscall_kill -> ~Sv.In x R -> ~~is_sarr (vtype x) -> - ~is_ok (get_var (evm s) x). - + move=> x /Sv_memP hin hnin; rewrite -(get_var_eq_except _ (vrvsP (spp:=mk_spp) hw)) //=. - rewrite /get_var kill_varsE hin /on_vu; case: (vtype x) => //. + (evm s).[x] = undef_addr (vtype x). + + move=> x /Sv_memP hin hnin. + have [<-]:= get_var_eq_ex false hnin (vrvsP (spp:=mk_spp) hw). + by rewrite /get_var kill_varsE hin; case: (vtype x). constructor => //=. + by rewrite (write_lvals_escs (spp:=mk_spp) hw). + by apply: write_lvals_emem hw; apply: get_lvar_to_lvals. - + rewrite (get_var_eq_except _ heqx) // /X; first by rewrite hgetrip hrip. + + rewrite heqx /X; first by rewrite hgetrip hrip. case: assemble_progP => -[] hripr hriprx hripxr hripf _ _ _. move=> /Sv.union_spec [] hin. + by have := SvP.MP.FM.diff_1 hin; rewrite /= /all_vars !Sv.union_spec => -[ | [ | []]] /sv_of_listP @@ -1677,38 +1659,35 @@ Proof. [elim: (hripr r) | elim: (hriprx r) | elim: (hripxr r)| elim: (hripf r) ]; rewrite hr. move: hin; rewrite /R /= vrvs_to_lvals => /sv_of_listP /(mapP (T1:= @ceqT_eqType _ _)) [r _] hr. by elim: (hripr r); rewrite hr. - + move=> r v. + + move=> r. case: (Sv_memP (to_var r) R) => hinR; first by apply hres. - case: (Sv_memP (to_var r) syscall_kill) => hinK heq1. - + by have /(_ erefl) := hkill _ hinK hinR; rewrite heq1. + case: (Sv_memP (to_var r) syscall_kill) => hinK. + + by rewrite (hkill _ hinK hinR) /=. move: (hinK); rewrite /syscall_kill => hnin. have : Sv.In (to_var r) one_varmap.callee_saved by have := reg_in_all r; SvD.fsetdec. rewrite /one_varmap.callee_saved /= => /sv_of_listP /mapP [x] /hpr. - move=> h /to_var_typed_reg ?; subst x; rewrite -h; apply hreg. - by rewrite -(get_var_eq_except _ heqx) // /X; SvD.fsetdec. - + move=> r v heq1. + by move=> h /to_var_typed_reg ?; subst x; rewrite -h heqx // /X; SvD.fsetdec. + + move=> r. have hinR : ~Sv.In (to_var r) R. + rewrite /R /= vrvs_to_lvals => /sv_of_listP. by move=> /(mapP (T1 := @ceqT_eqType _ _)) [x _] /(@sym_eq var);apply: to_var_reg_neq_regx. case: (Sv_memP (to_var r) syscall_kill) => hinK. - + by have /(_ erefl) := hkill _ hinK hinR; rewrite heq1. + + by have /(_ erefl) -> /= := hkill _ hinK hinR. move: (hinK); rewrite /syscall_kill => hnin. have : Sv.In (to_var r) one_varmap.callee_saved by have := regx_in_all r; SvD.fsetdec. rewrite /one_varmap.callee_saved /= => /sv_of_listP /mapP [x] /hpr. - move=> h /to_var_typed_regx ?; subst x; rewrite -h; apply hregx. - by rewrite -(get_var_eq_except _ heqx) // /X; SvD.fsetdec. - + move=> r v heq1. + by move=> h /to_var_typed_regx ?; subst x; rewrite -h heqx // /X; SvD.fsetdec. + + move=> r. have hinR : ~Sv.In (to_var r) R. + rewrite /R /= vrvs_to_lvals => /sv_of_listP. by move=> /(mapP (T1 := @ceqT_eqType _ _)) [x _] /(@sym_eq var); apply: to_var_reg_neq_xreg. case: (Sv_memP (to_var r) syscall_kill) => hinK. - + by have /(_ erefl) := hkill _ hinK hinR; rewrite heq1. + + by have /(_ erefl) -> /= := hkill _ hinK hinR. move: (hinK); rewrite /syscall_kill => hnin. have : Sv.In (to_var r) one_varmap.callee_saved by have := xreg_in_all r; SvD.fsetdec. rewrite /one_varmap.callee_saved /= => /sv_of_listP /mapP [x] /hpr. - move=> h /to_var_typed_xreg ?; subst x; rewrite -h; apply hxreg. - by rewrite -(get_var_eq_except _ heqx) // /X; SvD.fsetdec. - + move=> r v. + by move=> h /to_var_typed_xreg ?; subst x; rewrite -h heqx // /X; SvD.fsetdec. + + move=> r. have hinR : ~Sv.In (to_var r) R. + rewrite /R /= vrvs_to_lvals => /sv_of_listP. by move=> /(mapP (T1 := @ceqT_eqType _ _)) [x _]. @@ -1716,9 +1695,7 @@ Proof. + by rewrite /= => /sv_of_listP /mapP [] f /(allP callee_saved_not_bool) h /to_var_typed_flag ?; subst f. have hinK : Sv.In (to_var r) syscall_kill. + by rewrite /syscall_kill Sv.diff_spec;split => //; apply flag_in_all. - have /(_ erefl) := hkill _ hinK hinR. - rewrite /get_var /=. - case: _.[_]%vmap => // - [] // _ /ok_inj <-. + have /(_ erefl) -> /= := hkill _ hinK hinR. by case: (asm_flag _ _). - move=> [xlr | ] r ok_i. + case heqlr: to_reg => [lr /= | //] [?]; subst aci. @@ -1732,14 +1709,14 @@ Proof. rewrite -assemble_prog_labels -heqf ptr_eq. apply: eval_jumpP; last by apply hjump. rewrite /st_update_next /=. - have : write_var xlr (Vword ptr) (to_estate ls) = ok {| escs := lscs ls; emem := lmem ls; evm := vm |}. + have : write_var true xlr (Vword ptr) (to_estate ls) = ok {| escs := lscs ls; emem := lmem ls; evm := vm |}. + by rewrite /write_var /= hset. have {heqlr} heqlr := of_varI heqlr. by move=> /(lom_eqv_write_var MSB_CLEAR hloeq) -/(_ _ heqlr). move=> [?]; subst aci. rewrite /linear_sem.eval_instr => /=; t_xrbindP=> wsp vsp hsp htow_sp l hgetpc. rewrite heqf; case ptr_eq: encode_label => [ ptr | ] //. - t_xrbindP => m1 hm1 /=; rewrite sumbool_of_boolET /= => hjump. + t_xrbindP => m1 hm1 /= => hjump. apply (match_state_step1 (ls' := ls') hnth) => /=. rewrite /return_address_from. have /= := assemble_get_label_after_pc hass ok_i _ heqf hip _ hgetpc. @@ -1752,15 +1729,14 @@ Proof. rewrite hm1 /=; apply: eval_jumpP; last by apply hjump. set vi := {| v_var := to_var ad_rsp; v_info := dummy_var_info |}. set ls1 := (X in to_estate X). - have : write_var vi (Vword (wsp - wrepr reg_size (wsize_size reg_size))) (to_estate ls) = ok {| escs := lscs ls; emem := lmem ls; evm := lvm ls1 |}. - + rewrite /write_var /= sumbool_of_boolET /to_estate //= /with_vm /=. + have : write_var true vi (Vword (wsp - wrepr reg_size (wsize_size reg_size))) (to_estate ls) = ok {| escs := lscs ls; emem := lmem ls; evm := lvm ls1 |}. + + rewrite /write_var /= /to_estate //= /with_vm /=. by have [ ->] := to_var_rsp. move=> /(lom_eqv_write_var MSB_CLEAR hloeq) -/(_ ad_rsp erefl). by case=> *; constructor => //. - move=> hok_i [?]; subst aci; rewrite /linear_sem.eval_instr /=. t_xrbindP => wsp vsp hsp htow_sp ptr ok_ptr. - case ptr_eq: decode_label => [ r | // ] /=. - rewrite sumbool_of_boolET => hjump. + case ptr_eq: decode_label => [ r | // ] /= hjump. apply (match_state_step1 (ls' := ls') hnth) => /=. rewrite /eval_POP truncate_word_u /=. rewrite to_var_rsp in hsp. @@ -1773,8 +1749,8 @@ Proof. apply: eval_jumpP; last by apply hjump. set vi := {| v_var := to_var ad_rsp; v_info := dummy_var_info |}. set ls1 := (X in to_estate X). - have : write_var vi (Vword (wsp + wrepr reg_size (wsize_size reg_size))) (to_estate ls) = ok {| escs := lscs ls; emem := lmem ls; evm := lvm ls1 |}. - + rewrite /write_var /= sumbool_of_boolET /to_estate //= /with_vm /=. + have : write_var true vi (Vword (wsp + wrepr reg_size (wsize_size reg_size))) (to_estate ls) = ok {| escs := lscs ls; emem := lmem ls; evm := lvm ls1 |}. + + rewrite /write_var /= /to_estate //= /with_vm /=. by have [ ->] := to_var_rsp. move=> /(lom_eqv_write_var MSB_CLEAR hloeq) -/(_ ad_rsp erefl). by case=> *; constructor => //. @@ -1858,6 +1834,8 @@ Proof. apply: asmsem_trans x y. Qed. +(* ------------------------------------------------------------------------------ *) + Lemma asm_gen_exportcall fn scs m vm scs' m' vm' : lsem_exportcall p scs m fn vm scs' m' vm' -> vm_initialized_on vm (map var_of_asm_typed_reg callee_saved) @@ -1891,83 +1869,56 @@ Proof. - by apply/sv_of_listP. case: M => /= _ _ _ _ Mr Mrx Mxr Mf. case: M' => /= _ _ _ _ Mr' Mrx' Mxr' Mf'. - move/ok_vm: hr. + assert (h1 := Vm.getP vm (var_of_asm_typed_reg r)). + move/ok_vm: hr h1. case: r E => r /= E; [ move: (Mr' r) (Mr r) | move: (Mrx' r) (Mrx r) | move: (Mxr' r) (Mxr r) | move: (Mf' r) (Mf r) ]; rewrite /get_var E. - 1-3: by case: _.[_]%vmap => [ | [] // ] /= [] sz w sz_le /(_ _ erefl) /= X' /(_ _ erefl) /= X; - move => /is_okP[] _ /truncate_wordP[] /(cmp_le_antisym sz_le) ? _; subst sz; - rewrite -(word_uincl_eq X) -(word_uincl_eq X'). - case: _.[_]%vmap => [ | [] // ] /= b /(_ _ erefl) /= X' /(_ _ erefl) /= X _. - case: (asm_flag xm' r) X' => //= _ <-. - by case: (asm_flag xm r) X => //= _ <-. + 1-3: by move=> + + + /compat_valEl /= h; + case h => [-> //| [ws' [w ->]]] hle1 /= X' X /is_okP[] ? /truncate_wordP [] + /(cmp_le_antisym hle1) ? _; subst ws'; + rewrite -(word_uincl_eq X) -(word_uincl_eq X'). + move=> + + + /compat_valEl /= h /=. + case h => [-> //| [b ->]] /=. + by case: (asm_flag xm' r) => //= _ <-; case: (asm_flag xm r) => //= _ <-. Qed. Section VMAP_SET_VARS. - Context {t : stype} {T: eqType} `{ToIdent t T}. - Context (fromT: T -> exec (psem_t t)). - - Definition vmap_set_vars : vmap -> seq T -> vmap := - foldl (fun vm x => vm.[to_var x <- fromT x])%vmap. - - Definition is_ok_or_narr_undef x := - match fromT x with - | Ok _ => true - | Error ErrAddrUndef => if vtype (to_var x) is sarr _ - then false - else true - | Error _ => false - end. - - Lemma wf_vmap_set_vars vm xs : - wf_vm vm - -> all is_ok_or_narr_undef xs - -> wf_vm (vmap_set_vars vm xs). - Proof. - elim: xs vm => // x xs ih vm h /= /andP[] ok_x ok_xs; - apply: ih ok_xs. - move=> y; rewrite Fv.setP. - case: eqP => ?; last exact: h. - subst. - rewrite /is_ok_or_narr_undef in ok_x. - case: (fromT x) ok_x => // -[] //. - by case: (vtype (to_var x)). - Qed. + Context {t : stype} {T: Type} {tS:ToString t T} {tI:ToIdent T}. + Let T_eqType := @ceqT_eqType T _. Canonical T_eqType. + Context (fromT: T -> sem_ot t). + + Definition vmap_set_vars : Vm.t -> seq T -> Vm.t := + foldl (fun vm x => vm.[to_var x <- oto_val (fromT x)]). Lemma get_var_vmap_set_vars_other vm xs y : all (fun x => to_var x != y) xs - -> get_var (vmap_set_vars vm xs) y = get_var vm y. - Proof. - elim: xs vm => // x xs ih vm /= /andP[] x_neq_y /ih ->. - apply: get_var_neq. - exact/eqP. - Qed. + -> (vmap_set_vars vm xs).[y] = vm.[y]. + Proof. by elim: xs vm => // x xs ih vm /= /andP[] x_neq_y /ih ->; apply: Vm.setP_neq. Qed. + Lemma get_var_vmap_set_vars_other_type vm xs y : - vtype y != t - -> get_var (vmap_set_vars vm xs) y = get_var vm y. + vtype y != t -> + (vmap_set_vars vm xs).[y] = vm.[y]. Proof. move=> /eqP neqt; apply: get_var_vmap_set_vars_other. by apply/allP => x _; apply/eqP => ?; subst y. Qed. Lemma get_var_vmap_set_vars_finite vm xs y : - Finite.axiom xs - -> get_var (vmap_set_vars vm xs) (to_var y) - = on_vu (@pto_val t) undef_error (fromT y). + Finite.axiom xs -> + (vmap_set_vars vm xs).[to_var y] = oto_val (fromT y). Proof. - move=> finT. - move: vm. - + move=> finT; move: vm. have {finT} : y \in xs. - by rewrite -has_pred1 has_count finT. - elim: xs => // x xs; rewrite inE. case y_xs: (y \in xs). - move=> /(_ erefl) ih _ vm; exact: ih. rewrite orbF => _ /eqP <-{x} vm /=. - rewrite get_var_vmap_set_vars_other; first exact: get_var_eq. + rewrite get_var_vmap_set_vars_other. + + by rewrite Vm.setP_eq vm_truncate_val_eq // type_of_oto_val. apply/allP => x x_xs. apply/eqP => h; have ? := inj_to_var h. subst x. @@ -1987,52 +1938,33 @@ Proof. Qed. Definition vmap_of_asm_mem - (sp : word Uptr) (rip rsp : Ident.ident) (s : asmmem) : vmap := - let pword_of_reg r := ok (pword_of_word (asm_reg s r)) in - let pword_of_regx rx := ok (pword_of_word (asm_regx s rx)) in - let pword_of_xreg xr := ok (pword_of_word (asm_xreg s xr)) in - let pbool_of_flag f := if asm_flag s f is Def b - then ok b - else pundef_addr sbool in - let vm := vmap0.[mk_ptr rsp <- ok (pword_of_word sp)] - .[mk_ptr rip <- ok (pword_of_word (asm_rip s))]%vmap in - let vm := vmap_set_vars (t := sword _) pword_of_reg vm registers in - let vm := vmap_set_vars (t := sword _) pword_of_regx vm registerxs in - let vm := vmap_set_vars (t := sword _) pword_of_xreg vm xregisters in + (sp : word Uptr) (rip rsp : Ident.ident) (s : asmmem) := + + let pword_of_reg r := (asm_reg s r : sem_ot (sword reg_size)) in + let pword_of_regx rx := (asm_regx s rx: sem_ot (sword reg_size)) in + let pword_of_xreg xr := (asm_xreg s xr: sem_ot (sword xreg_size)) in + let pbool_of_flag f := (if asm_flag s f is Def b then Some b else None : sem_ot sbool) in + let vm := Vm.init.[mk_ptr rsp <- Vword sp] + .[mk_ptr rip <- Vword (asm_rip s)] in + let vm := vmap_set_vars pword_of_reg vm registers in + let vm := vmap_set_vars pword_of_regx vm registerxs in + let vm := vmap_set_vars pword_of_xreg vm xregisters in let vm := vmap_set_vars (t := sbool) pbool_of_flag vm rflags in vm. -Lemma wf_vmap_of_asm_mem sp rip rsp s : - wf_vm (vmap_of_asm_mem sp rip rsp s). -Proof. - repeat apply: wf_vmap_set_vars. - 1-5: rewrite /is_ok_or_narr_undef /=. - - - repeat apply: wf_vm_set. exact: wf_vmap0. - - exact: all_xpredT. - - exact: all_xpredT. - - exact: all_xpredT. - - elim: rflags => // r rflags IH. - apply/andP. - split. - + by case: (asm_flag _ _). - + exact: IH. -Qed. - -Definition get_typed_reg_value (st : asmmem) (r : asm_typed_reg) : exec value := +Definition get_typed_reg_value (st : asmmem) (r : asm_typed_reg) : value := match r with - | ARReg r => ok (Vword (asm_reg st r)) - | ARegX r => ok (Vword (asm_regx st r)) - | AXReg r => ok (Vword (asm_xreg st r)) - | ABReg r => Let b := get_rf (asm_flag st) r in ok (Vbool b) + | ARReg r => Vword (asm_reg st r) + | ARegX r => Vword (asm_regx st r) + | AXReg r => Vword (asm_xreg st r) + | ABReg r => of_rbool (asm_flag st r) end. -Definition get_typed_reg_values st rs : exec values := - mapM (get_typed_reg_value st) rs. +Definition get_typed_reg_values st rs : values := + map (get_typed_reg_value st) rs. Lemma get_var_vmap_of_asm_mem sp rip rsp s (r : asm_typed_reg) : - get_var (vmap_of_asm_mem sp rip rsp s) (var_of_asm_typed_reg r) - = get_typed_reg_value s r. + (vmap_of_asm_mem sp rip rsp s).[var_of_asm_typed_reg r] = get_typed_reg_value s r. Proof. rewrite /vmap_of_asm_mem. assert (h := sword_reg_neq_xreg). @@ -2043,7 +1975,7 @@ Proof. by apply/allP => /= x _; rewrite eq_sym; apply/eqP/to_var_reg_neq_regx. + by rewrite get_var_vmap_set_vars_finite //=; exact: cenumP. + by rewrite get_var_vmap_set_vars_finite //=; exact: cenumP. - by rewrite get_var_vmap_set_vars_finite //= /get_rf; [case: (asm_flag s r) | exact: cenumP]. + by rewrite get_var_vmap_set_vars_finite /=;[case: (asm_flag s r)| exact: cenumP]. Qed. Definition estate_of_asm_mem @@ -2064,45 +1996,23 @@ Proof. + apply/allP => /= r _; apply/eqP. exact: rip_not_regx. rewrite get_var_vmap_set_vars_other; last first. + apply/allP => /= r _; apply/eqP. exact: rip_not_reg. - by rewrite get_var_eq. - - move => r v. - by rewrite (get_var_vmap_of_asm_mem _ _ _ _ (ARReg r)) => /= /ok_inj <-. - - move => r v. - by rewrite (get_var_vmap_of_asm_mem _ _ _ _ (ARegX r)) => /= /ok_inj <-. - - move => r v. - by rewrite (get_var_vmap_of_asm_mem _ _ _ _ (AXReg r)) => /= /ok_inj <-. - move => r v. - rewrite /= /vmap_of_asm_mem. - set pbool_of_flag := fun f => if asm_flag s f is Def b - then ok b - else pundef_addr sbool. - pose (q := - (vmap_set_vars (λ xr : cfinT_finType, ok (pword_of_word (asm_xreg s xr))) - (vmap_set_vars (λ rx : cfinT_finType, ok (pword_of_word (asm_regx s rx))) - (vmap_set_vars (λ r0 : cfinT_finType, ok (pword_of_word (asm_reg s r0))) - (vmap0 .[ mk_ptr rsp <- ok (pword_of_word sp)]) .[ mk_ptr rip <- - ok (pword_of_word (asm_rip s))] registers) registerxs) xregisters)%vmap). - rewrite -/q. - generalize - (get_var_vmap_set_vars_finite (t := sbool) pbool_of_flag q r cenumP). - rewrite get_varE. - rewrite /pbool_of_flag. - case: _.[_]%vmap => /=; - case: (asm_flag s r) => //=. - - by move => ? ? /ok_inj -> /ok_inj ->. - by move => _ [] -> /ok_inj ->. + by rewrite Vm.setP_eq //= cmp_le_refl. + - by move => r; rewrite (get_var_vmap_of_asm_mem _ _ _ _ (ARReg r)). + - by move => r; rewrite (get_var_vmap_of_asm_mem _ _ _ _ (ARegX r)). + - by move => r; rewrite (get_var_vmap_of_asm_mem _ _ _ _ (AXReg r)). + by move => r; rewrite (get_var_vmap_of_asm_mem _ _ _ _ (ABReg r)). Qed. End PROG. Lemma lom_eqv_ext rip s xs vm : - Fv.ext_eq (evm s) vm -> + (evm s) =1 vm -> lom_eqv rip s xs -> lom_eqv rip (with_vm s vm) xs. Proof. move=> heq [] h1 h2 h3 h4 h5 h6 h7 h8; split => //=; - first (by rewrite /get_var -heq); - by move=> r v; rewrite /get_var -heq; auto. + first (by rewrite -heq); + by move=> r; rewrite -heq; auto. Qed. Definition sem_sopn_t '(o, xs, es) s := diff --git a/proofs/compiler/allocation.v b/proofs/compiler/allocation.v index c592625d9..c73b72039 100644 --- a/proofs/compiler/allocation.v +++ b/proofs/compiler/allocation.v @@ -31,13 +31,6 @@ Definition fold2 := error "fold2". End E. -Definition wextend_type t1 t2 := - (t1 == t2) || - match t1, t2 with - | sword s1, sword s2 => (s1 <= s2)%CMP - | _, _ => false - end. - Module M. Module Mv. @@ -177,12 +170,15 @@ Module M. if b as b0 return ({b0} + {~~ b0}) then left (erefl true) else right (erefl true). - Definition v_wextendty x y := wextend_type (vtype x) (vtype y). + Section WSW. + Context {wsw : WithSubWord}. - Definition v_wextendtyP x y := bool_dec (v_wextendty x y). + Definition v_compat_type x y := compat_type sw_allowed (vtype x) (vtype y). + + Definition v_compat_typeP x y := bool_dec (v_compat_type x y). Definition mset_valid (mvar: Mvar.t var) (mset:Sv.t) := - forall x id, Mvar.get mvar x = Some id -> Sv.In x mset /\ v_wextendty x id. + forall x id, Mvar.get mvar x = Some id -> Sv.In x mset /\ v_compat_type x id. Record t_ := mkT { mv : Mv.t; @@ -195,7 +191,7 @@ Module M. Definition get (m:t) (x:var) := Mv.get (mv m) x. Lemma mset_valid_set m x id : - v_wextendty x id -> + v_compat_type x id -> mset_valid (Mv.mvar (Mv.set (mv m) x id)) (Sv.add x (mset m)). Proof. move=> hsub y idy;rewrite Mvar.setP;case: eqP => ?. @@ -207,7 +203,7 @@ Module M. Arguments set m x id h : clear implicits. Lemma mset_valid_add m x id : - v_wextendty x id -> + v_compat_type x id -> mset_valid (Mv.mvar (Mv.add (mv m) x id)) (Sv.add x (mset m)). Proof. move=> h y idy;rewrite Mvar.setP;case: eqP => ?. @@ -219,7 +215,7 @@ Module M. Arguments add m x id h : clear implicits. Definition addc m x id := - if v_wextendtyP x id is left h then add m x id h + if v_compat_typeP x id is left h then add m x id h else m. Lemma mset_valid_empty s : mset_valid (Mv.mvar Mv.empty) s. @@ -275,9 +271,9 @@ Module M. Lemma addcP m x id y : get (addc m x id) y = - if v_wextendty x id && (x == y) then Some id else get m y. + if v_compat_type x id && (x == y) then Some id else get m y. Proof. - rewrite /addc;case: v_wextendtyP => [ heq | /negbTE -> //]. + rewrite /addc;case: v_compat_typeP => [ heq | /negbTE -> //]. by rewrite heq addP. Qed. @@ -314,7 +310,7 @@ Module M. + by move=> ? H;apply Hl;rewrite in_cons H orbC. rewrite /f /P. have /Hl -/merge_auxP Hp := mem_head p l. - have : v_wextendty p.1 p.2. + have : v_compat_type p.1 p.2. + have : get m1 p.1 = Some p.2 \/ get m2 p.1 = Some p.2 by intuition. by move=> [] /svalid []. by rewrite addcP => ->; case:eqP => [<- [<-] //| ne ];apply Hm. @@ -329,14 +325,14 @@ Module M. have : P (empty_s (Sv.union (mset m1) (mset m2))). + by rewrite /P /empty_s. have : - (forall p, p \in Mvar.elements (merge_aux m1 m2) -> v_wextendty p.1 p.2). + (forall p, p \in Mvar.elements (merge_aux m1 m2) -> v_compat_type p.1 p.2). + move=> p /Mvar.elementsP -/merge_auxP ?. have : get m1 p.1 = Some p.2 \/ get m2 p.1 = Some p.2 by intuition. by move=> [] /svalid []. elim : Mvar.elements (empty_s _) => //= -[x idx] l Hl m Hp Hm. apply Hl;first by move=> p hin;apply Hp;rewrite in_cons hin orbT. move:Hm;rewrite /f /P /addc /=. - case: v_wextendtyP => [? | ]. + case: v_compat_typeP => [? | ]. + rewrite addP_mset;SvD.fsetdec. by have /= -> := Hp _ (mem_head (x, idx) l). Qed. @@ -395,8 +391,15 @@ Module M. by have := @mergeP_mset r1 r2;SvD.fsetdec. Qed. + End WSW. + Arguments add {wsw} m x id h. + Arguments set {wsw} m x id h. + End M. +Section WSW. +Context {wsw : WithSubWord}. + Definition alloc_error := pp_internal_error_s "allocation". Definition cerr_varalloc xi1 xi2 s:= @@ -405,68 +408,62 @@ Definition cerr_varalloc xi1 xi2 s:= Definition check_v xi1 xi2 (m:M.t) : cexec M.t := let x1 := xi1.(v_var) in let x2 := xi2.(v_var) in - if M.v_wextendtyP x1 x2 is left h then + if M.v_compat_typeP x1 x2 is left h then match M.get m x1 with | None => - if Sv.mem x1 (M.mset m) then - Error (cerr_varalloc xi1 xi2 "variable already set") - else ok (M.set m x1 x2 h) + Let _ := assert (~~Sv.mem x1 (M.mset m)) (cerr_varalloc xi1 xi2 "variable already set") in + ok (M.set m x1 x2 h) | Some x2' => - if x2 == x2' then ok m - else Error (cerr_varalloc xi1 xi2 "variable mismatch") + Let _ := assert (x2 == x2') (cerr_varalloc xi1 xi2 "variable mismatch") in ok m end else Error (cerr_varalloc xi1 xi2 "type mismatch"). Definition error_e := pp_internal_error_s "allocation" "expression are not equal". Definition check_gv x1 x2 (m:M.t) : cexec M.t := - if x1.(gs) == x2.(gs) then - if is_lvar x1 then check_v x1.(gv) x2.(gv) m - else - if x1.(gv).(v_var) == x2.(gv).(v_var) then ok m - else Error error_e - else Error error_e. + Let _ := assert (x1.(gs) == x2.(gs)) error_e in + if is_lvar x1 then check_v x1.(gv) x2.(gv) m + else + Let _ := assert (x1.(gv).(v_var) == x2.(gv).(v_var)) error_e in ok m. Fixpoint check_e (e1 e2:pexpr) (m:M.t) : cexec M.t := match e1, e2 with | Pconst n1, Pconst n2 => - if n1 == n2 then ok m else Error error_e + Let _ := assert (n1 == n2) error_e in ok m | Pbool b1, Pbool b2 => - if b1 == b2 then ok m else Error error_e + Let _ := assert (b1 == b2) error_e in ok m | Parr_init n1, Parr_init n2 => - if n1 == n2 then ok m else Error error_e + Let _ := assert (n1 == n2) error_e in ok m | Pvar x1, Pvar x2 => check_gv x1 x2 m | Pget aa1 w1 x1 e1, Pget aa2 w2 x2 e2 => - if (aa1 == aa2) && (w1 == w2) then check_gv x1 x2 m >>= check_e e1 e2 else Error error_e + Let _ := assert ((aa1 == aa2) && (w1 == w2)) error_e in + check_gv x1 x2 m >>= check_e e1 e2 | Psub aa1 w1 len1 x1 e1, Psub aa2 w2 len2 x2 e2 => - if (aa1 == aa2) && (w1 == w2) && (len1 == len2) then check_gv x1 x2 m >>= check_e e1 e2 - else Error error_e + Let _ := assert ([&& aa1 == aa2, w1 == w2 & len1 == len2]) error_e in + check_gv x1 x2 m >>= check_e e1 e2 | Pload w1 x1 e1, Pload w2 x2 e2 => - if w1 == w2 then check_v x1 x2 m >>= check_e e1 e2 else Error error_e + Let _ := assert (w1 == w2) error_e in + check_v x1 x2 m >>= check_e e1 e2 | Papp1 o1 e1, Papp1 o2 e2 => - if o1 == o2 then check_e e1 e2 m - else Error error_e + Let _ := assert (o1 == o2) error_e in check_e e1 e2 m | Papp2 o1 e11 e12, Papp2 o2 e21 e22 => - if o1 == o2 then check_e e11 e21 m >>= check_e e12 e22 - else Error error_e + Let _ := assert (o1 == o2) error_e in check_e e11 e21 m >>= check_e e12 e22 | PappN o1 es1, PappN o2 es2 => - if o1 == o2 - then fold2 (alloc_error "check_e (appN)") check_e es1 es2 m - else Error error_e + Let _ := assert (o1 == o2) error_e in + fold2 (alloc_error "check_e (appN)") check_e es1 es2 m | Pif t e e1 e2, Pif t' e' e1' e2' => - if t == t' then - check_e e e' m >>= check_e e1 e1' >>= check_e e2 e2' - else Error error_e + Let _ := assert (t == t') error_e in + check_e e e' m >>= check_e e1 e1' >>= check_e e2 e2' | _, _ => Error error_e end. -Definition check_var_aux (x1 x2:var) m (h:M.v_wextendty x1 x2): cexec M.t := +Definition check_var_aux (x1 x2:var) m (h:M.v_compat_type x1 x2): cexec M.t := ok (M.set m x1 x2 h). Definition check_varc (xi1 xi2:var_i) m : cexec M.t := let x1 := xi1.(v_var) in let x2 := xi2.(v_var) in - if M.v_wextendtyP x1 x2 is left h then check_var_aux m h + if M.v_compat_typeP x1 x2 is left h then check_var_aux m h else Error (cerr_varalloc xi1 xi2 "type mismatch"). Definition is_Pvar (e:option (stype * pexpr)) := @@ -480,29 +477,29 @@ Definition error_lv := pp_internal_error_s "allocation" "lval not equal". Definition check_lval (e2:option (stype * pexpr)) (x1 x2:lval) m : cexec M.t := match x1, x2 with | Lnone _ t1, Lnone _ t2 => - if wextend_type t1 t2 then ok m else Error error_lv + Let _ := assert (compat_type sw_allowed t1 t2) error_lv in + ok m | Lnone _ t1, Lvar x => - if wextend_type t1 x.(v_var).(vtype) then - ok (M.remove m x.(v_var)) - else Error error_lv + Let _ := assert (compat_type sw_allowed t1 x.(v_var).(vtype)) error_lv in + ok (M.remove m x.(v_var)) | Lvar x1 , Lvar x2 => match is_Pvar e2 with | Some (ty, x2') => - if M.v_wextendtyP x1 x2 is left h then - if (vtype x1 == ty) && (vtype x1 == vtype x2) && (x2.(v_var) == x2') then ok (M.add m x1 x2 h) + if M.v_compat_typeP x1 x2 is left h then + if [&& vtype x1 == ty, vtype x1 == vtype x2 & x2.(v_var) == x2'] then ok (M.add m x1 x2 h) else check_var_aux m h else Error (cerr_varalloc x1 x2 "type mismatch") | _ => check_varc x1 x2 m end | Lmem w1 x1 e1, Lmem w2 x2 e2 => - if w1 == w2 then check_v x1 x2 m >>= check_e e1 e2 else Error error_lv + Let _ := assert (w1 == w2) error_lv in + check_v x1 x2 m >>= check_e e1 e2 | Laset aa1 w1 x1 e1, Laset aa2 w2 x2 e2 => - if (aa1 == aa2) && (w1 == w2) then check_v x1 x2 m >>= check_e e1 e2 >>= check_varc x1 x2 - else Error error_lv + Let _ := assert ((aa1 == aa2) && (w1 == w2)) error_lv in + check_v x1 x2 m >>= check_e e1 e2 >>= check_varc x1 x2 | Lasub aa1 w1 len1 x1 e1, Lasub aa2 w2 len2 x2 e2 => - if (aa1 == aa2) && (w1 == w2) && (len1 == len2) then check_v x1 x2 m >>= check_e e1 e2 >>= check_varc x1 x2 - else Error error_lv - + Let _ := assert [&& aa1 == aa2, w1 == w2 & len1 == len2] error_lv in + check_v x1 x2 m >>= check_e e1 e2 >>= check_varc x1 x2 | _ , _ => Error error_lv end. @@ -549,35 +546,35 @@ Context Fixpoint check_i (i1 i2:instr_r) r := match i1, i2 with | Cassgn x1 _ ty1 e1, Cassgn x2 _ ty2 e2 => - if ty1 == ty2 then - check_e e1 e2 r >>= check_lval (Some (ty2,e2)) x1 x2 - else Error (alloc_error "bad type in assignment") + Let _ := assert (ty1 == ty2) (alloc_error "bad type in assignment") in + check_e e1 e2 r >>= check_lval (Some (ty2,e2)) x1 x2 + | Copn xs1 _ o1 es1, Copn xs2 _ o2 es2 => - if o1 == o2 then - check_es es1 es2 r >>= check_lvals xs1 xs2 - else Error (alloc_error "operators not equals") + Let _ := assert (o1 == o2) (alloc_error "operators not equals") in + check_es es1 es2 r >>= check_lvals xs1 xs2 + | Csyscall xs1 o1 es1, Csyscall xs2 o2 es2 => - if o1 == o2 then - check_es es1 es2 r >>= check_lvals xs1 xs2 - else Error (alloc_error "operators not equals") + Let _ := assert (o1 == o2) (alloc_error "syscall not equals") in + check_es es1 es2 r >>= check_lvals xs1 xs2 | Ccall _ x1 f1 arg1, Ccall _ x2 f2 arg2 => - if f1 == f2 then - check_es arg1 arg2 r >>= check_lvals x1 x2 - else Error (alloc_error "functions not equals") + Let _ := assert (f1 == f2) (alloc_error "functions not equals") in + check_es arg1 arg2 r >>= check_lvals x1 x2 + | Cif e1 c11 c12, Cif e2 c21 c22 => Let re := check_e e1 e2 r in Let r1 := fold2 E.fold2 check_I c11 c21 re in Let r2 := fold2 E.fold2 check_I c12 c22 re in ok (M.merge r1 r2) + | Cfor x1 (d1,lo1,hi1) c1, Cfor x2 (d2,lo2,hi2) c2 => - if d1 == d2 then - Let rhi := check_e lo1 lo2 r >>=check_e hi1 hi2 in - let check_c r := - check_var x1 x2 r >>= - fold2 E.fold2 check_I c1 c2 in - loop check_c Loop.nb rhi - else Error (alloc_error "loop directions not equals") + Let _ := assert (d1 == d2) (alloc_error "loop directions not equals") in + Let rhi := check_e lo1 lo2 r >>=check_e hi1 hi2 in + let check_c r := + check_var x1 x2 r >>= + fold2 E.fold2 check_I c1 c2 in + loop check_c Loop.nb rhi + | Cwhile a1 c1 e1 c1', Cwhile a2 c2 e2 c2' => let check_c r := Let r := fold2 E.fold2 check_I c1 c2 r in @@ -604,20 +601,18 @@ Context {T:eqType} {pT:progT T}. Variable (init_alloc : extra_fun_t -> extra_prog_t -> extra_prog_t -> cexec M.t). Definition check_fundef (ep1 ep2 : extra_prog_t) (f1 f2: funname * fundef) (_:Datatypes.unit) := - let (f1,fd1) := f1 in let (f2,fd2) := f2 in add_funname f1 (add_finfo fd1.(f_info) ( - if (f1 == f2) && (fd1.(f_tyin) == fd2.(f_tyin)) && (fd1.(f_tyout) == fd2.(f_tyout)) && - (fd1.(f_extra) == fd2.(f_extra)) then + Let _ := assert [&& f1 == f2, fd1.(f_tyin) == fd2.(f_tyin), fd1.(f_tyout) == fd2.(f_tyout) & + fd1.(f_extra) == fd2.(f_extra)] (E.error "functions not equal") in Let r := init_alloc fd1.(f_extra) ep1 ep2 in Let r := check_vars fd1.(f_params) fd2.(f_params) r in Let r := check_cmd fd1.(f_body) fd2.(f_body) r in let es1 := map Plvar fd1.(f_res) in let es2 := map Plvar fd2.(f_res) in Let _r := check_es es1 es2 r in - ok tt - else Error (E.error "functions not equals"))). + ok tt)). Definition check_prog_error := alloc_error "check_fundef (fold2)". @@ -654,3 +649,5 @@ Definition check_sprog := check_prog init_alloc_sprog. End SPROG. End WITH_PARAMS. + +End WSW. diff --git a/proofs/compiler/allocation_proof.v b/proofs/compiler/allocation_proof.v index 94c592ece..485accfe3 100644 --- a/proofs/compiler/allocation_proof.v +++ b/proofs/compiler/allocation_proof.v @@ -9,145 +9,94 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope vmap. Local Open Scope seq_scope. Section WITH_PARAMS. Context + {wsw : WithSubWord} + {dc:DirectCall} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} {sip : SemInstrParams asm_op syscall_state}. -Lemma wextend_typeP t1 t2 : - reflect (t1 = t2 \/ exists s1 s2, [/\ t1 = sword s1, t2 = sword s2 & (s1 <= s2)%CMP]) - (wextend_type t1 t2). -Proof. - apply (iffP orP); (move => -[/eqP | ];first by left). - + by case: t1 => // s1; case: t2 => // s2; right; exists s1, s2. - by move=> [] s1 [] s2 [ -> -> ?]; right. -Qed. - -Lemma extend_subtype t1 t2 : wextend_type t1 t2 -> subtype t1 t2. -Proof. by move=> /wextend_typeP [ -> | []s1[]s2[-> -> ?]]. Qed. - -Lemma wextend_type_pundef_addr t1 t2 : - wextend_type t1 t2 -> eval_uincl (pundef_addr t1) (pundef_addr t2). -Proof. move/wextend_typeP => [-> | []s1[]s2[]->->?] //=. Qed. - -Lemma wextend_typeP_bool t: wextend_type sbool t -> t = sbool. -Proof. by move=>/wextend_typeP => -[ -> | []?[]?[]]. Qed. - -Lemma eval_uincl_ok_undefb t1 t2 v1 v2 : - wextend_type t1 t2 -> - eval_uincl v1 v2 -> - (∃ v' : psem_t t1, v1 = ok v') ∨ v1 = undef_error ∧ t1 = sbool -> - (∃ v' : psem_t t2, v2 = ok v') ∨ v2 = undef_error ∧ t2 = sbool. -Proof. - move=> hex hu [[v1' ?] | [? hx1]]; subst v1. - + by move: hu => /=; case: v2 => //; eauto. - move: hex v2 hu;rewrite hx1 => /wextend_typeP_bool ->. - by case => /= [ | ? <-]; eauto. -Qed. - -Lemma subtype_pof_val_ok t1 t2 v v1 : - wextend_type t1 t2 -> - pof_val t1 v = ok v1 -> - exists2 v2, pof_val t2 v = ok v2 & value_uincl (pto_val v1) (pto_val v2). -Proof. - move=>/wextend_typeP [ <- | []s1[]s2[?? hle]]; first by eauto. - subst t1 t2 => /=; case: v => //=; last by case. - move=> s' w [<-]; eexists; first reflexivity. - case: Sumbool.sumbool_of_bool => e /=. - + by rewrite (sumbool_of_boolET (cmp_le_trans e hle)). - case: Sumbool.sumbool_of_bool => e' /=. - + move: e => /negbT e. - by apply/andP; split => //; exact: cmp_nle_le. - rewrite -(zero_extend_idem _ hle). - exact: word_uincl_zero_ext. -Qed. - -Definition eq_alloc (r:M.t) (vm1 vm2:vmap) := - [/\ vm_uincl vmap0 vm2, - (forall x, ~Sv.In x (M.mset r) -> vm1.[x] = pundef_addr x.(vtype)) & +Definition eq_alloc (r:M.t) (vm1 vm2:Vm.t) := + [/\ (forall x, ~Sv.In x (M.mset r) -> vm1.[x] = undef_addr x.(vtype)) & (forall x x', M.get r x = Some x' -> - eval_uincl vm1.[x] vm2.[x'])]. + value_uincl vm1.[x] vm2.[x'])]. -Lemma eq_alloc_empty: eq_alloc M.empty vmap0 vmap0. -Proof. by split;rewrite /vm_uincl=> *;rewrite /vmap0 !Fv.get0. Qed. +Lemma eq_alloc_empty: eq_alloc M.empty Vm.init Vm.init. +Proof. by split => * //; rewrite Vm.initP. Qed. Lemma eq_alloc_incl r1 r2 vm vm': M.incl r2 r1 -> eq_alloc r1 vm vm' -> eq_alloc r2 vm vm'. Proof. - move=> /M.inclP [Hi Hsub] [ Huincl epa eqa];split=>//. + move=> /M.inclP [Hi Hsub] [ epa eqa];split=>//. + by move=> x Hx;apply epa;SvD.fsetdec. move=> x x'; case: (Sv_memP x (M.mset r1)) => [ /Hi H /H /eqa // | /epa -> hget]. - have := Huincl x'. - have [_ /(_ x') /= heq _ ]:= eq_alloc_empty. - rewrite heq;last by rewrite SvD.F.empty_iff. - apply: eval_uincl_trans; apply/subtype_eval_uincl_pundef/extend_subtype. - by have []:= M.svalid hget. + apply subtype_value_uincl_undef. + have [_ /compat_type_undef_t ->] := M.svalid hget; apply subtype_undef_get. Qed. -Lemma check_vP x1 x2 r re vm1 vm2 : +Lemma check_vP wdb x1 x2 r re vm1 vm2 : check_v x1 x2 r = ok re -> eq_alloc r vm1 vm2 -> eq_alloc re vm1 vm2 /\ (forall v1 : value, - get_var vm1 x1 = ok v1 -> - exists v2 : value, get_var vm2 x2 = ok v2 /\ value_uincl v1 v2). + get_var wdb vm1 x1 = ok v1 -> + exists v2 : value, get_var wdb vm2 x2 = ok v2 /\ value_uincl v1 v2). Proof. - rewrite /check_v;case: M.v_wextendtyP => // hsub. + rewrite /check_v;case: M.v_compat_typeP => // hsub. case Hget : M.get => [id | ]. - + case: eqP => //= ? [<-];subst id => Hea;split=>//. - case: Hea => _ _ /(_ _ _ Hget) Hev v1 {Hget} Hget. - case: x1 x2 hsub Hget Hev=> [[xt1 xn1] ii1] [[xt2 xn2] ii2] /= hsub. - rewrite /get_var;apply: on_vuP => //= t -> <- /=. - by case: (vm2.[_])%vmap => //= z' Hz';exists (pto_val z'). - case: ifPn => //= /Sv_memP Hnot [] <- [ Hvm0 Hset Huincl];split;first split=>//. + + t_xrbindP => /eqP ? <- Hea; subst id; split => //. + case: Hea => _ /(_ _ _ Hget) Hev v1 {Hget}. + rewrite /get_var; t_xrbindP => /(value_uincl_defined Hev) -> <- /=; eauto. + t_xrbindP => /Sv_memP Hnot <- [ Hset Huincl]; split; first split => //. + by move=> x;rewrite M.setP_mset => ?;apply Hset;SvD.fsetdec. + move=> x id;rewrite M.setP;case:eqP => [<- [<-]| Hne]. + rewrite (Hset _ Hnot) /=. - apply: (eval_uincl_trans (wextend_type_pundef_addr hsub)). - by have := Hvm0 x2; rewrite Fv.get0. + by apply value_uincl_undef; rewrite (compat_type_undef_t hsub) (compat_type_undef_t (Vm.getP vm2 x2)). by case:ifP => // _;apply Huincl. move=> v1;rewrite /get_var (Hset _ Hnot) //=. - case: x2 hsub (Hvm0 x2) => [[xt2 xn2] ?] /= hsub;rewrite Fv.get0 /= => heval. - apply on_vuP => [ v heq| //] ?;subst v1. - have : eval_uincl (pundef_addr (vtype x1)) vm2.[{| vtype := xt2; vname := xn2 |}]. - + by apply: eval_uincl_trans heval; apply wextend_type_pundef_addr. - by rewrite heq; case: (vm2.[_]) => //= a ?; eexists;split;first by reflexivity. + t_xrbindP; case: wdb => /=. + + move=> /is_defined_undef_addr [len heq] <-. + move: hsub (Vm.getP vm2 x2); rewrite /M.v_compat_type heq. + move => /compat_typeEl -> /compat_typeE /type_of_valI [a] -> /=. + by exists (Varr a); split => //; apply: WArray.uincl_empty. + move=> _ <-; eexists; split; eauto. + apply value_uincl_undef. + by rewrite (compat_type_undef_t hsub) (compat_type_undef_t (Vm.getP vm2 x2)). Qed. -Lemma check_gvP x1 x2 r re gd vm1 vm2 : +Lemma check_gvP wdb x1 x2 r re gd vm1 vm2 : check_gv x1 x2 r = ok re -> eq_alloc r vm1 vm2 -> eq_alloc re vm1 vm2 /\ (forall v1 : value, - get_gvar gd vm1 x1 = ok v1 -> - exists v2 : value, get_gvar gd vm2 x2 = ok v2 /\ value_uincl v1 v2). + get_gvar wdb gd vm1 x1 = ok v1 -> + exists v2 : value, get_gvar wdb gd vm2 x2 = ok v2 /\ value_uincl v1 v2). Proof. rewrite /check_gv /get_gvar /is_lvar; case: x1 x2 => x1 k1 [x2 k2] /=. - case:eqP => [-> | //]; case:eqP => _; first by apply check_vP. - case:eqP => [-> [<-] ?| //]; split;eauto. + t_xrbindP => /eqP ->; case:eqP => _; first by apply check_vP. + t_xrbindP => /eqP -> <-; split; eauto. Qed. Lemma is_PvarP e ty x : is_Pvar e = Some (ty,x) -> e = Some (ty, Plvar x). Proof. by case: e => //= -[? []] //= [] v [] // [<- <-]. Qed. Section CHECK_EP. - Context (gd: glob_decls) (vm2: vmap). + Context (wdb : bool) (gd : glob_decls) (vm2 : Vm.t). Let P e1 : Prop := ∀ e2 r re vm1, check_e e1 e2 r = ok re → eq_alloc r vm1 vm2 → eq_alloc re vm1 vm2 ∧ ∀ scs m v1, - sem_pexpr gd {| escs := scs; emem := m ; evm := vm1 |} e1 = ok v1 → - ∃ v2, sem_pexpr gd {| escs := scs; emem := m ; evm := vm2 |} e2 = ok v2 ∧ + sem_pexpr wdb gd {| escs := scs; emem := m ; evm := vm1 |} e1 = ok v1 → + ∃ v2, sem_pexpr wdb gd {| escs := scs; emem := m ; evm := vm2 |} e2 = ok v2 ∧ value_uincl v1 v2. Let Q es1 : Prop := @@ -156,8 +105,8 @@ Section CHECK_EP. eq_alloc r vm1 vm2 → eq_alloc re vm1 vm2 ∧ ∀ scs m vs1, - sem_pexprs gd {| escs := scs; emem := m ; evm := vm1 |} es1 = ok vs1 → - ∃ vs2, sem_pexprs gd {| escs := scs; emem := m ; evm := vm2 |} es2 = ok vs2 ∧ + sem_pexprs wdb gd {| escs := scs; emem := m ; evm := vm1 |} es1 = ok vs1 → + ∃ vs2, sem_pexprs wdb gd {| escs := scs; emem := m ; evm := vm2 |} es2 = ok vs2 ∧ List.Forall2 value_uincl vs1 vs2. Lemma check_e_esP : (∀ e, P e) ∧ (∀ es, Q es). @@ -171,38 +120,30 @@ Section CHECK_EP. move: he1 => /(_ _ _ _ ok_v1) [] v2 [] -> hv. move: hes1 => /(_ _ _ _ ok_vs1) [] vs2 [] -> hvs. eexists; split; first reflexivity. by constructor. - - move => z1 [] // z2 r re vm1. - by case: ifPn => // /eqP <- [->] ?; split=> // ??? [] <-; exists z1. - - move => b1 [] // b2 r re vm1. - by case: ifPn => // /eqP <- [->] ?;split=> // ??? [] <-; exists b1. - - move => n1 [] // n2 r re vm1. - by case: eqP => //= <- [<-] ?; split => // ??? [<-]; eauto. + - by move => z1 [] // z2 r re vm1; t_xrbindP => /eqP <- -> ?; split=> // ??? [] <-; exists z1. + - by move => b1 [] // b2 r re vm1; t_xrbindP => /eqP <- -> ?; split=> // ??? [] <-; exists b1. + - by move => n1 [] // n2 r re vm1; t_xrbindP => /eqP <- <- ?; split => //= ??? [<-]; eauto. - move => x1 [] // x2 r re vm1. - by move=> /check_gvP Hv /(Hv gd) [Hea H]. + by move=> /check_gvP Hv /(Hv wdb gd) [Hea H]. - move => aa1 sz1 x1 e1 He1 [] // aa2 sz2 x2 e2 r re vm1. - case: andP => // -[/eqP ? /eqP ?]; subst aa2 sz2. - apply: rbindP => r' Hcv Hce Hea. - have [Hea' Hget]:= check_gvP gd Hcv Hea. + t_xrbindP => r' /andP [/eqP ? /eqP ?] Hcv Hce Hea; subst aa2 sz2. + have [Hea' Hget]:= check_gvP wdb gd Hcv Hea. have [Hre Hse1]:= He1 _ _ _ _ Hce Hea';split => //= scs m v1. apply: on_arr_gvarP => n t Heqt /Hget [v2 []]. rewrite /on_arr_var; case: v2 => //= n' t' -> /WArray.uincl_get Ht. - t_xrbindP=> w ve /Hse1 [v2 [-> ]] /[swap] /to_intI -> /value_uinclE -> - ? /= /Ht -> /= <-. + t_xrbindP=> w ve /Hse1 [v2 [-> ]] /[swap] /to_intI -> /value_uinclE -> ? /= /Ht -> /= <-. by eauto. - move => aa1 sz1 len1 x1 e1 He1 [] // aa2 sz2 len2 x2 e2 r re vm1. - case: andP => // -[] /andP[] /eqP ? /eqP ? /eqP ?; subst aa2 sz2 len2. - apply: rbindP => r' Hcv Hce Hea. - have [Hea' Hget]:= check_gvP gd Hcv Hea. + t_xrbindP => r' /and3P [/eqP ? /eqP ? /eqP ?] Hcv Hce Hea; subst aa2 sz2 len2. + have [Hea' Hget]:= check_gvP wdb gd Hcv Hea. have [Hre Hse1]:= He1 _ _ _ _ Hce Hea';split => //= scs m v1. apply: on_arr_gvarP => n t Heqt /Hget [v2 []]. rewrite /on_arr_var; case: v2 => //= n' t' -> /WArray.uincl_get_sub Ht. - t_xrbindP => w ve /Hse1 [v2 [-> ]] /[swap] /to_intI -> /value_uinclE -> - ? /= /Ht [? -> ?] <- /=. + t_xrbindP => w ve /Hse1 [v2 [-> ]] /[swap] /to_intI -> /value_uinclE -> ? /= /Ht [? -> ?] <- /=. by eauto. - move => sz1 x1 e1 He1 [] // sz2 x2 e2 r re vm1. - case: eqP => // ->. - apply: rbindP => r' Hcv Hce Hea. - have [Hea' Hget]:= check_vP Hcv Hea. + t_xrbindP => r' /eqP -> Hcv Hce Hea. + have [Hea' Hget]:= check_vP wdb Hcv Hea. have [Hre Hse1]:= He1 _ _ _ _ Hce Hea';split => //= scs m v1. t_xrbindP => w1 ve1 /Hget [ve1' [->]] /[swap] /to_wordI [? [? [-> ]]] /word_uincl_truncate h /value_uinclE [? [? [-> /h{h} /= ->]]] @@ -210,253 +151,178 @@ Section CHECK_EP. /word_uincl_truncate h /value_uinclE [? [? [-> /h{h} /= ->]]] ? /= -> /= ->. by eauto. - move => op1 e1 He1 [] // op2 e2 r re vm1. - case: eqP => // <-. move=> H /(He1 _ _ _ _ H) [Hea Hse1];split=>//=. - move=> scs m v1;apply:rbindP => v /Hse1 [v1'] [-> U1]. + t_xrbindP => /eqP <- H /(He1 _ _ _ _ H) [Hea Hse1];split=>//= scs m v1. + t_xrbindP => v /Hse1 [v1'] [-> U1]. by move=> /(vuincl_sem_sop1 U1);exists v1. - move => op1 e11 He11 e12 He12 [] // op2 e21 e22 r re vm1. - case: eqP => // <-;apply:rbindP => r' Hs1 Hs2 Hea. + t_xrbindP => r' /eqP <- Hs1 Hs2 Hea. have [Hea' Hse1]:= He11 _ _ _ _ Hs1 Hea. have [? Hse2]:= He12 _ _ _ _ Hs2 Hea'; split => //= scs m v. - apply: rbindP => v1 /Hse1 [v1' [-> U1]]. - apply: rbindP => v2 /Hse2 [v2' [-> U2]]. + t_xrbindP => v1 /Hse1 [v1' [-> U1]] v2 /Hse2 [v2' [-> U2]]. by move=> /(vuincl_sem_sop2 U1 U2);exists v. - move => op1 es1 Hes1 [] // op2 es2 r re vm1. - case: eqP => // <- {op2} ok_re hr. + t_xrbindP => /eqP <- ok_re hr. move: Hes1 => /(_ _ _ _ _ _ ok_re hr) [] hre h. split => //= scs m v1; t_xrbindP => vs1 ok_vs1 ok_v1. - rewrite -/(sem_pexprs _ _). + rewrite -/(sem_pexprs _ _ _). move: h => /(_ _ _ _ ok_vs1) [] vs2 [] -> hs /=. by have [] := vuincl_sem_opN ok_v1 hs; eauto. move => t e He e11 He11 e12 He12 [] // t' e2 e21 e22 r re vm1. - case: eqP => // <-. - t_xrbindP => r1 r' /He Hr' /He11 Hr1 /He12 Hr2 {He He11 He12}. + t_xrbindP => r1 r' /eqP <- /He Hr' /He11 Hr1 /He12 Hr2 {He He11 He12}. move=> /Hr'{Hr'}[] /Hr1{Hr1}[] /Hr2{Hr2}[] Hre Hs2 Hs1 Hs;split=>// scs m v1. t_xrbindP=> b > /Hs [_] /= [->] /= /[swap] /to_boolI -> /value_uinclE ->. move=> ?? /Hs1 [?[-> /=]] /value_uincl_truncate H/H{H} [? -> ?]. move=> ?? /Hs2 [?[-> /=]] /value_uincl_truncate H/H{H} [? -> ?] <- /=. by eexists;split;eauto;case: (b). -Qed. + Qed. End CHECK_EP. -Definition check_eP gd e1 e2 r re vm1 vm2 := - (check_e_esP gd vm2).1 e1 e2 r re vm1. +Definition check_eP wdb gd e1 e2 r re vm1 vm2 := + (check_e_esP wdb gd vm2).1 e1 e2 r re vm1. -Lemma vm_uincl0_set vm x (v : exec (psem_t (vtype x))) : - vm_uincl vmap0 vm -> - ((exists v', v = ok v') \/ v = undef_error) -> - vm_uincl vmap0 vm.[x <- apply_undef v]. -Proof. - move=> Hvm0 H z; case (x =P z) => [<- | /eqP Hne]. - + rewrite Fv.setP_eq /vmap0 Fv.get0 /=. - by case: H => [[v']|] ?;subst v => //=;apply eval_uincl_undef. - by rewrite Fv.setP_neq. -Qed. - -Lemma eq_alloc_set x1 (v1 :exec (psem_t (vtype x1))) r x2 (v2 :exec (psem_t (vtype x2))) - vm1 vm2 (h:M.v_wextendty x1 x2) : +Lemma eq_alloc_set x1 v1 r x2 v2 vm1 vm2 (h:M.v_compat_type x1 x2) : eq_alloc r vm1 vm2 -> - eval_uincl v1 v2 -> - ((exists v', v1 = ok v') \/ (v1 = undef_error /\ vtype x1 = sbool)) -> - eq_alloc (M.set r x1 x2 h) vm1.[x1 <- apply_undef v1] - vm2.[x2 <- apply_undef v2]. + value_uincl (vm_truncate_val (vtype x1) v1) (vm_truncate_val (vtype x2) v2) -> + eq_alloc (M.set r x1 x2 h) vm1.[x1 <- v1] vm2.[x2 <- v2]. Proof. - move=> [Hvm0 Hin Hget] Hu H1. - have H2:= eval_uincl_ok_undefb h Hu H1. + move=> [Hin Hget] Hu. split. - + apply vm_uincl0_set => //;intuition. + move=> z;rewrite M.setP_mset => Hnin. - by rewrite Fv.setP_neq;[apply Hin|apply /eqP];SvD.fsetdec. + by rewrite Vm.setP_neq;[apply Hin|apply /eqP];SvD.fsetdec. move=> x id;rewrite M.setP;case:eqP => [<-[<-] | /eqP Hne]. - + rewrite !Fv.setP_eq. - case: H1 Hu => [ [v1' ?]| [? heq1]];subst v1; - case: H2 => [ [v2' ?]| [? heq2]];subst v2 => //=; last by rewrite heq1 heq2. - by move: h v2'; rewrite /M.v_wextendty heq1 => /wextend_typeP_bool ->. + + by rewrite !Vm.setP_eq. case: ifPn => //= /Sv_memP Hid Hgetx. - rewrite !Fv.setP_neq //;first by apply Hget. + rewrite !Vm.setP_neq //;first by apply Hget. move: Hgetx;rewrite M.Mv.mvalid => Hgetx. by apply/eqP => ?; subst id; apply: Hid. Qed. -Lemma eq_alloc_add x1 (v1:exec (psem_t (vtype x1))) r x2 vm1 vm2 (h:M.v_wextendty x1 x2) : +Lemma eq_alloc_add x1 v1 r x2 vm1 vm2 (h:M.v_compat_type x1 x2) : eq_alloc r vm1 vm2 -> let v2 := vm2.[x2] in - eval_uincl v1 v2 -> - ((exists v', v1 = ok v') \/ (v1 = undef_error /\ vtype x1 = sbool)) -> - eq_alloc (M.add r x1 x2 h) vm1.[x1 <- apply_undef v1] - vm2.[x2 <- apply_undef v2]. + value_uincl (vm_truncate_val (vtype x1) v1) (vm_truncate_val (vtype x2) v2) -> + eq_alloc (M.add r x1 x2 h) vm1.[x1 <- v1] + vm2.[x2 <- v2]. Proof. - move=> [Hvm0 Hin Hget] v2 /= Hu H1. - have H2:= eval_uincl_ok_undefb h Hu H1. + move=> [Hin Hget] v2 /= Hu. split. - + by apply vm_uincl0_set => //;intuition. - + move=> z;rewrite M.addP_mset => Hnin. - by rewrite Fv.setP_neq;[apply Hin|apply /eqP];SvD.fsetdec. - move=> x id;rewrite M.addP;case:eqP => [<-[<-] | /eqP Hne]. - + rewrite !Fv.setP_eq. - case: H1 Hu => [ [v1' ?]| [? heq1]];subst v1; - case: H2 => [ [v2' ->]| [-> heq2]] => //=;last by rewrite heq1 heq2. - by move: h v2'; rewrite /M.v_wextendty heq1 => /wextend_typeP_bool ->. - move=> hx;rewrite Fv.setP_neq //. - case: (x2 =P id) => [? | /eqP hne];last by rewrite Fv.setP_neq //;apply Hget. - subst;rewrite Fv.setP_eq;have := Hget _ _ hx. - move: H2;rewrite /v2 => -[ [v' ->]| [-> ?]] /=; case : vm1.[x] => //= -[] // _. - by case: (vtype id). + + move=> z; rewrite M.addP_mset => Hnin. + by rewrite Vm.setP_neq; [apply Hin|apply /eqP]; SvD.fsetdec. + move=> x id; rewrite M.addP; case:eqP => [<-[<-] | /eqP Hne]. + + by rewrite !Vm.setP_eq. + move=> /Hget {} Hget; rewrite Vm.setP_neq //. + rewrite Vm.setP; case: eqP; last by []. + by subst v2 => ->; rewrite vm_truncate_val_get. Qed. -Lemma check_varP r1 r1' vm1 vm2 vm1' x1 x2 v1 v2 (h:M.v_wextendty x1 x2): +Lemma check_varP wdb r1 r1' vm1 vm2 vm1' x1 x2 v1 v2 (h:M.v_compat_type x1 x2): eq_alloc r1 vm1 vm2 -> - @check_var_aux x1 x2 r1 h = ok r1' -> - set_var vm1 x1 v1 = ok vm1' -> + @check_var_aux _ x1 x2 r1 h = ok r1' -> + set_var wdb vm1 x1 v1 = ok vm1' -> value_uincl v1 v2 -> - exists vm2' : vmap, - set_var vm2 x2 v2 = ok vm2' /\ eq_alloc r1' vm1' vm2'. + exists2 vm2' : Vm.t, + set_var wdb vm2 x2 v2 = ok vm2' & eq_alloc r1' vm1' vm2'. Proof. rewrite /check_var => Hea -[<-]. - apply: set_varP; rewrite /set_var. - + move=> vx1 hvx1 <- hu. - have [vx1' [hv2x1 hvx1']]:= pof_val_uincl hu hvx1. - have [vx2 -> hsub /=] := subtype_pof_val_ok h hv2x1. - eexists;split;first reflexivity. - have hincl: eval_uincl (ok vx1) (ok vx2). - + by apply: (eval_uincl_trans (v2:= ok vx1')). - by apply (eq_alloc_set h Hea hincl); eauto. - move=> v1' Hv1' <- Hu. - case: x1 v1' h Hv1' (h) => t1 x1 /= /eqP ?;subst t1. - case: x2 => t2 x2 h;rewrite /M.v_wextendty => /to_bool_undef ? /=;subst v1. - move=> h0; have ? := wextend_typeP_bool h0; subst t2; move: Hu => /eqP heq. - have := type_of_valI v2; rewrite -heq => -[? | [b ?]]; subst v2 => /=; - eexists; (split; first reflexivity). - + have hincl : @eval_uincl sbool sbool undef_error undef_error by done. - by apply (eq_alloc_set h Hea hincl);eauto. - have hincl : @eval_uincl sbool sbool undef_error (ok b) by done. - apply (eq_alloc_set h Hea hincl);eauto. + move=> /set_varP [hdb1 htr1 ->] hu. + have [htr2 hu2 hdb2]:= compat_truncate_uincl h htr1 hu hdb1. + by rewrite set_var_truncate //; eexists; eauto; apply eq_alloc_set. Qed. -Lemma check_varcP r1 r1' vm1 vm2 vm1' x1 x2 v1 v2 : +Lemma check_varcP wdb r1 r1' vm1 vm2 vm1' x1 x2 v1 v2 : eq_alloc r1 vm1 vm2 -> check_varc x1 x2 r1 = ok r1' -> - set_var vm1 x1 v1 = ok vm1' -> + set_var wdb vm1 x1 v1 = ok vm1' -> value_uincl v1 v2 -> - exists vm2' : vmap, - set_var vm2 x2 v2 = ok vm2' /\ eq_alloc r1' vm1' vm2'. -Proof. - by rewrite /check_varc; case: M.v_wextendtyP => // h; apply check_varP. -Qed. + exists2 vm2' : Vm.t, + set_var wdb vm2 x2 v2 = ok vm2' & eq_alloc r1' vm1' vm2'. +Proof. by rewrite /check_varc; case: M.v_compat_typeP => // h; apply check_varP. Qed. Lemma eq_alloc_rm r x s vm z : - eval_uincl (pundef_addr (vtype x)) z -> + value_uincl (undef_addr (vtype x)) (vm_truncate_val (vtype x) z) -> eq_alloc r (evm s) vm -> eq_alloc (M.remove r x) (evm s) vm.[x <- z]. Proof. - move=> Hz [Hmap0 Hinit Halloc];split. - + move=> y;case:(x =P y) => [<-|/eqP ne]. - + by rewrite Fv.setP_eq /vmap0 Fv.get0. - by rewrite Fv.setP_neq. + move=> Hz [Hinit Halloc];split. + by move=> y /=;apply: Hinit. move=> x0 id; rewrite M.removeP. case: M.get (Halloc x0) => [id' | ] //. move=> /(_ _ (refl_equal _));case:ifPn => //= Hne He [?];subst id'. - rewrite Fv.setP_neq //;by apply: contra Hne => /eqP ->. + rewrite Vm.setP_neq //;by apply: contra Hne => /eqP ->. Qed. -Lemma check_lvalP gd r1 r1' x1 x2 e2 s1 s1' vm1 v1 v2 : +Lemma check_lvalP wdb gd r1 r1' x1 x2 e2 s1 s1' vm1 v1 v2 : check_lval e2 x1 x2 r1 = ok r1' -> eq_alloc r1 s1.(evm) vm1 -> value_uincl v1 v2 -> oapp (fun te2 => - sem_pexpr gd (with_vm s1 vm1) te2.2 >>= truncate_val te2.1 = ok v2) true e2 -> - write_lval gd x1 v1 s1 = ok s1' -> - exists vm1', - write_lval gd x2 v2 (with_vm s1 vm1) = ok (with_vm s1' vm1') /\ + sem_pexpr wdb gd (with_vm s1 vm1) te2.2 >>= truncate_val te2.1 = ok v2) true e2 -> + write_lval wdb gd x1 v1 s1 = ok s1' -> + exists2 vm1', + write_lval wdb gd x2 v2 (with_vm s1 vm1) = ok (with_vm s1' vm1') & eq_alloc r1' s1'.(evm) vm1'. Proof. case: x1 x2 => /= [ii1 t1 | x1 | sz1 x1 p1 | aa1 sz1 x1 p1 | aa1 sz1 len1 x1 p1] [ii2 t2 | x2 | sz2 x2 p2 | aa2 sz2 x2 p2 | aa2 sz2 len2 x2 p2] //=. - + case:ifP => //= hs [] <- ? Hv _ H. - have [-> [ [u hpof]| [hpof ?]]]:= write_noneP H; rewrite /write_none. - + have [v1' ]:= subtype_pof_val_ok hs hpof. - by move=> /(pof_val_uincl Hv) [v2' [-> ]] /= ??;eauto. - subst t1; have ? := wextend_typeP_bool hs; subst t2. - have [->|[b] ->] /=:= pof_val_undef Hv hpof; eauto. - + case:ifP => //= hs [] <- Heqa Hu Happ H. - have [-> ]:= write_noneP H. - rewrite /write_var /set_var => -[ [u]| ]. - + move=> /(subtype_pof_val_ok hs) [v3]. - move=> /(pof_val_uincl Hu) [z' [-> ?]] /= ?. - eexists; rewrite with_vm_idem;split; eauto. - by apply eq_alloc_rm => //; apply eval_uincl_undef. - move=> [hpof ?];subst t1; case : x2 hs => -[tx2 x2] ii2 /= /wextend_typeP_bool ?;subst tx2. - have [->|[b] ->] /= := pof_val_undef Hu hpof; eexists;(split; first by eauto); - apply eq_alloc_rm => //. - + rewrite /write_var=> Hc Hvm1 Hv Happ; apply rbindP => vm1' Hset [<-] /=. - move: Hc;case: is_Pvar (@is_PvarP e2). - + move=> [ty x] /(_ _ _ (refl_equal _)) ?;subst e2. - case: M.v_wextendtyP => // ht;case:ifPn; last first. - + move=> ? hc;have [vm2' [-> /= ?]]:= check_varP Hvm1 hc Hset Hv;eexists. - by rewrite !with_vm_idem;eauto. - move=> /andP[]/andP[]/eqP ? /eqP heqt /eqP;subst ty. - move: x1 x2 x heqt ht Hset Happ=> [[xt1 xn1] ii1] [[xt2 xn2] ii2] [x ii] /=. - set x1 := {| vname := xn1 |}; set x2 := {| vname := xn2 |}. - move=> hteq ht hset; t_xrbindP => v2' Happ htr ? ?;subst => /=. - apply: set_varP hset => /=;rewrite /set_var. - + move=> v1' Hv1 ?;subst. - apply: on_vuP Happ => //. - move=> v2_ hv2_ ?;subst. - have ?:= truncate_pto_val htr;subst v2. - rewrite pof_val_pto_val /=;eexists;rewrite !with_vm_idem;split;first reflexivity. - have /= := @eq_alloc_add x1 (ok v1') r1 x2 (evm s1) vm1 ht Hvm1. - rewrite hv2_ /= /pval_uincl => H;apply H;last by eauto. - by apply (value_uincl_pof_val Hv1 Hv). - move=> /= hniw hv1 ?;subst; rewrite hniw /=. - apply: on_vuP Happ => //. - move=> v2_ heq ?;subst;have ?:= truncate_pto_val htr;subst v2. - rewrite pof_val_pto_val /=;eexists;rewrite !with_vm_idem;split;first reflexivity. - have /= := @eq_alloc_add x1 (pundef_addr xt2) r1 x2 (evm s1) vm1 ht Hvm1. - rewrite heq /= apply_undef_pundef_addr=> H;apply H. - + by apply eval_uincl_undef. - by move /eqP: hniw => ->;right. - by move=> ? hc;have [vm2' [-> /= ?]]:= check_varcP Hvm1 hc Hset Hv;eexists; - rewrite !with_vm_idem;eauto. - + case: eqP => // -> /=. - t_xrbindP => r2 Hcv Hce Hvm1 Hv Happ wx vx. - have [Hr2 H/H{H} [vx' [-> ]]]:= check_vP Hcv Hvm1. + + t_xrbindP => hs <- ? Hv _ H. + have [ -> htr hdb]:= write_noneP H; rewrite /write_none. + have [ -> hu' -> /=]:= compat_truncate_uincl hs htr Hv hdb; eauto. + + t_xrbindP => hs <- Heqa Hu Happ H. + have [-> htr hdb]:= write_noneP H; rewrite /write_var /set_var. + have [-> hu' -> /=]:= compat_truncate_uincl hs htr Hu hdb. + rewrite with_vm_idem; eexists; eauto. + apply eq_alloc_rm => //=. + by apply/value_uincl_undef; rewrite -(compat_type_undef_t (vm_truncate_val_compat v2 _)). + + rewrite /write_var=> Hc Hvm1 Hv Happ; t_xrbindP => vm1' Hset <- /=. + move: Hc;case: is_Pvar (@is_PvarP e2); last first. + + by move=> ? hc;have [vm2' -> /= ?]:= check_varcP Hvm1 hc Hset Hv;eexists; rewrite ?with_vm_idem;eauto. + move=> [ty x] /(_ _ _ (refl_equal _)) ?;subst e2. + case: M.v_compat_typeP => // ht;case:ifPn; last first. + + move=> ? hc;have [vm2' -> /= ?]:= check_varP Hvm1 hc Hset Hv. + by eexists; rewrite ?with_vm_idem; eauto. + move=> /and3P[] /eqP ? /eqP heqt /eqP; subst ty. + move: x1 x2 x heqt ht Hset Happ=> [x1 ii1] [ x2 ii2] [x ii] /=; rewrite /get_gvar /= /get_var. + t_xrbindP => hteq ht hset v2' _ ? htr ? ?; subst v2' x r1' => /=. + have := truncate_val_subtype_eq htr; rewrite hteq => /(_ (getP_subtype _ _)) ?; subst v2. + move/set_varP: hset => [hdb htr1 ->]; rewrite /set_var. + have [-> hu' -> /=] := compat_truncate_uincl ht htr1 Hv hdb. + exists vm1.[x2 <- vm1.[x2]] => //. + apply: eq_alloc_add ht Hvm1 hu'. + + + t_xrbindP => r2 /eqP -> Hcv Hce Hvm1 Hv Happ wx vx. + have [Hr2 H/H{H} [vx' [-> ]]]:= check_vP wdb Hcv Hvm1. move=> /of_value_uincl_te h/(h (sword _) _){h} /= -> >. case: (s1) Hvm1 Hr2 => scs1 sm1 svm1 /= Hvm1 Hr2. - have [Hr1' H/H{H} [ve' [-> ]]]:= check_eP gd Hce Hr2. - move=> /of_value_uincl_te h/(h (sword _) _){h} /= -> ? - /(@of_value_uincl_te (sword _) _ _ _ Hv) /= -> ? /= -> <-. - by eexists. - + case: andP => // -[/eqP -> /eqP ->] /=. - t_xrbindP => r2 r3 Hcv Hce Hcva Hvm1 Hv Happ. + have [Hr1' H/H{H} [ve' [-> ]]]:= check_eP wdb gd Hce Hr2. + by move=> /of_value_uincl_te h/(h (sword _) _){h} /= -> ? + /(@of_value_uincl_te (sword _) _ _ _ Hv) /= -> ? /= -> <-; eexists. + + t_xrbindP => r2 r3 /andP [] /eqP -> /eqP -> Hcv Hce Hcva Hvm1 Hv Happ. apply: on_arr_varP => n t Htx;rewrite /on_arr_var /=. - have [Hr3 H/H{H} [vx2 [->]]]:= check_vP Hcv Hvm1. + have [Hr3 H/H{H} [vx2 [->]]]:= check_vP wdb Hcv Hvm1. case: vx2 => //= n0 t2 Ht. t_xrbindP => we ve. case: (s1) Hvm1 Hr3 => scs1 sm1 svm1 /= Hvm1 Hr3. - have [Hr1' H/H{H} [ve' [-> ]]]:= check_eP gd Hce Hr3. + have [Hr1' H/H{H} [ve' [-> ]]]:= check_eP wdb gd Hce Hr3. move=> /of_value_uincl_te h/(h sint _){h} /= -> ? /(@of_value_uincl_te (sword _) _ _ _ Hv) /= -> ? /(WArray.uincl_set Ht) [? [/= -> Ht2']]. have: value_uincl (Varr _) (Varr _) := Ht2'. - rewrite /write_var; t_xrbindP=> /(check_varcP Hr1' Hcva) h ? - /h{h} [vm2' [/= -> ?]] <-. - by eexists. - case: andP => // -[] /andP[] /eqP -> /eqP -> /eqP -> /=. - t_xrbindP=> r2 r3 Hcv Hce Hcva Hvm1 Hv Happ. + by rewrite /write_var; t_xrbindP=> /(check_varcP Hr1' Hcva) h ? + /h{h} [vm2' /= -> ?] <-; eexists. + t_xrbindP=> r2 r3 /and3P[]/eqP -> /eqP -> /eqP -> Hcv Hce Hcva Hvm1 Hv Happ. apply: on_arr_varP => n t Htx;rewrite /on_arr_var /=. - have [Hr3 H/H{H} [vx2 [->]]]:= check_vP Hcv Hvm1. + have [Hr3 H/H{H} [vx2 [->]]]:= check_vP wdb Hcv Hvm1. case: vx2 => //= n0 t2 Ht. t_xrbindP => we ve. case: (s1) Hvm1 Hr3 => scs1 sm1 svm1 /= Hvm1 Hr3. - have [Hr1' H/H{H} [ve' [-> ]]]:= check_eP gd Hce Hr3. + have [Hr1' H/H{H} [ve' [-> ]]]:= check_eP wdb gd Hce Hr3. move=> /of_value_uincl_te h/(h sint _){h} /= -> ? /(@of_value_uincl_te (sarr _) _ _ _ Hv) [? /= -> ] - /(WArray.uincl_set_sub Ht) h ? /h{h}[? /= -> Ht2']. + /(WArray.uincl_set_sub Ht) h ? /h{h} [? /= -> Ht2']. have: value_uincl (Varr _) (Varr _) := Ht2'. - rewrite /write_var; t_xrbindP=> /(check_varcP Hr1' Hcva) h ? - /h{h} [vm2' [/= -> ?]] <-. - by eexists. + by rewrite /write_var; t_xrbindP=> /(check_varcP Hr1' Hcva) h ? + /h{h} [vm2' /= -> ?] <-; eexists. Qed. Section PROG. @@ -470,9 +336,9 @@ Variable init_alloc : extra_fun_t -> extra_prog_t -> extra_prog_t -> cexec M.t. Hypothesis init_allocP : forall (ef: extra_fun_t) (ep1 ep2: extra_prog_t) ev s1 scs m r, init_alloc ef ep1 ep2 = ok r -> - init_state ef ep1 ev (Estate scs m vmap0) = ok s1 -> + init_state ef ep1 ev (Estate scs m Vm.init) = ok s1 -> exists vm2, - init_state ef ep2 ev (Estate scs m vmap0) = ok (with_vm s1 vm2) /\ + init_state ef ep2 ev (Estate scs m Vm.init) = ok (with_vm s1 vm2) /\ eq_alloc r s1.(evm) vm2. Local Notation check_fundef := (check_fundef init_alloc). @@ -490,7 +356,7 @@ Lemma check_fundef_meta ep1 ep2 ffd1 ffd2 u u' : ]. Proof. case: ffd1 ffd2 => f1 fd1 [] f2 fd2. - by rewrite /check_fundef; case: andP => // - [] /andP[] /andP[] /eqP -> /eqP -> /eqP -> /eqP -> _. + by rewrite /check_fundef; t_xrbindP => /and4P [] /eqP -> /eqP -> /eqP -> /eqP -> . Qed. Section PROOF. @@ -515,109 +381,98 @@ Section PROOF. elim => [ | [fn1' fd1'] pf1 Hrec] [ | [fn2 fd2] pf2] //. apply: rbindP => -[] Hc /Hrec {Hrec} Hrec. have ? : fn1' = fn2. - + by move: Hc;rewrite /check_fundef; case:ifP => // /andP[]/andP[]/andP[]/eqP. + + by move: Hc;rewrite /check_fundef; t_xrbindP => /and4P[]/eqP. subst=> fn fd1;rewrite !get_fundef_cons. - case:ifPn => [/eqP -> [] <-| _ /Hrec //]. - by exists fd2. + by case:ifPn => [/eqP -> [] <-| _ /Hrec //]; exists fd2. Qed. Let Pi_r s1 (i1:instr_r) s2:= forall r1 i2 r2 vm1, eq_alloc r1 (evm s1) vm1 -> check_i i1 i2 r1 = ok r2 -> - exists vm2, eq_alloc r2 (evm s2) vm2 /\ + exists2 vm2, eq_alloc r2 (evm s2) vm2 & sem_i p2 ev (with_vm s1 vm1) i2 (with_vm s2 vm2). Let Pi s1 (i1:instr) s2:= forall r1 i2 r2 vm1, eq_alloc r1 (evm s1) vm1 -> check_I i1 i2 r1 = ok r2 -> - exists vm2, eq_alloc r2 (evm s2) vm2 /\ + exists2 vm2, eq_alloc r2 (evm s2) vm2 & sem_I p2 ev (with_vm s1 vm1) i2 (with_vm s2 vm2). Let Pc s1 (c1:cmd) s2:= forall r1 c2 r2 vm1, eq_alloc r1 (evm s1) vm1 -> check_cmd c1 c2 r1 = ok r2 -> - exists vm2, eq_alloc r2 (evm s2) vm2 /\ + exists2 vm2, eq_alloc r2 (evm s2) vm2 & sem p2 ev (with_vm s1 vm1) c2 (with_vm s2 vm2). Let Pfor (i1:var_i) vs s1 c1 s2 := forall i2 r1 r1' c2 r2 vm1, eq_alloc r1 (evm s1) vm1 -> check_var i1 i2 r1 = ok r1' -> check_cmd c1 c2 r1' = ok r2 -> M.incl r1 r2 -> - exists vm2, eq_alloc r1 (evm s2) vm2 /\ + exists2 vm2, eq_alloc r1 (evm s2) vm2 & sem_for p2 ev i2 vs (with_vm s1 vm1) c2 (with_vm s2 vm2). Let Pfun scs m fn vargs1 scs' m' vres := forall vargs2, List.Forall2 value_uincl vargs1 vargs2 -> - exists vres', - sem_call p2 ev scs m fn vargs2 scs' m' vres' /\ + exists2 vres', + sem_call p2 ev scs m fn vargs2 scs' m' vres' & List.Forall2 value_uincl vres vres'. Local Lemma Hskip : sem_Ind_nil Pc. - Proof. - move=> s r1 [ | ??] //= r2 vm1 ? [] <-;exists vm1;split=>//;constructor. - Qed. + Proof. move=> s r1 [ | ??] //= r2 vm1 ? [] <-;exists vm1 =>//;constructor. Qed. Local Lemma Hcons : sem_Ind_cons p1 ev Pc Pi. Proof. move=> s1 s2 s3 i c _ Hi _ Hc r1 [ | i2 c2] //= r2 vm1 /Hi Hvm1. - apply: rbindP => r3 /Hvm1 [vm2 []] /Hc Hvm2 ? /Hvm2. - by move=> [vm3 [??]];exists vm3;split=>//;econstructor;eauto. + t_xrbindP => r3 /Hvm1 [vm2 /Hc Hvm2 ?] /Hvm2 [vm3 ??]. + exists vm3 =>//;econstructor;eauto. Qed. Local Lemma HmkI : sem_Ind_mkI p1 ev Pi_r Pi. Proof. - move=> ii i s1 s2 _ Hi r1 [? i2] r2 vm1 /Hi Hvm /= /add_iinfoP /Hvm [vm2 [??]]. - by exists vm2;split=>//;constructor. + move=> ii i s1 s2 _ Hi r1 [? i2] r2 vm1 /Hi Hvm /= /add_iinfoP /Hvm [vm2 ??]. + by exists vm2 => //;constructor. Qed. Local Lemma Hassgn : sem_Ind_assgn p1 Pi_r. Proof. move => s1 s2 x tag ty e v v'. case: s1 => scs1 sm1 svm1 He Htr Hw r1 [] //= x2 tag2 ty2 e2 r2 vm1 Hvm1. - rewrite /check_i. - case: eqP => // <- {ty2}; t_xrbindP. - move=> r1' /check_eP -/(_ (p_globs p1) _ _ Hvm1) [Hr1'] /(_ _ _ _ He) [v2 [He2 Hu2]] Hcx. + rewrite /check_i; t_xrbindP => r1' /eqP <- /check_eP -/(_ true (p_globs p1) _ _ Hvm1) + [Hr1'] /(_ _ _ _ He) [v2 [He2 Hu2]] Hcx. have [v2' Htr' Hu2']:= value_uincl_truncate Hu2 Htr. - have /(_ _ Hr1') [|]:= check_lvalP Hcx _ Hu2' _ Hw. + have /(_ _ Hr1') [|vm2 Hwv Hvm2]:= check_lvalP Hcx _ Hu2' _ Hw. + by rewrite /= He2 /= Htr'. - move=> vm2 [Hwv Hvm2]. - by exists vm2; split=>//;econstructor;rewrite -?eq_globs;eauto. + by exists vm2 =>//;econstructor;rewrite -?eq_globs;eauto. Qed. - Lemma check_esP e1 e2 r re s vm: + Lemma check_esP wdb e1 e2 r re s vm: check_es e1 e2 r = ok re -> eq_alloc r s.(evm) vm -> eq_alloc re s.(evm) vm /\ - forall v1, sem_pexprs gd s e1 = ok v1 -> - exists v2, sem_pexprs (p_globs p2) (with_vm s vm) e2 = ok v2 /\ + forall v1, sem_pexprs wdb gd s e1 = ok v1 -> + exists v2, sem_pexprs wdb (p_globs p2) (with_vm s vm) e2 = ok v2 /\ List.Forall2 value_uincl v1 v2. Proof. - rewrite -eq_globs;case: s => sscs sm svm. - rewrite /check_es; elim: e1 e2 r => [ | e1 es1 Hrec] [ | e2 es2] r //=. - + by move=> [] <- ?;split=>// -[] //= ?;exists [::]. - move=> H Hea;apply: rbindP H => r' /(check_eP gd) /(_ Hea) [] Hea' He. - move=> /Hrec /(_ Hea') [] Hre Hes;split=> // v1. - rewrite /sem_pexprs;apply: rbindP => ve1 h. - have [{h}ve2 /=[-> Hve]]:= He _ _ _ h. - apply:rbindP => ev2 /Hes [ves2 []];rewrite /sem_pexprs => -> Hves [] <- /=. - by exists (ve2 :: ves2);split => //;constructor. + case: s => scs mem vm1. + rewrite -eq_globs => h1 h2; case (check_e_esP wdb gd vm) => _ /(_ _ _ _ _ _ _ h1 h2) /= [h3 h4]. + split => // v1; apply h4. Qed. - Lemma check_lvalsP gd xs1 xs2 vs1 vs2 r1 r2 s1 s2 vm1 : + Lemma check_lvalsP wdb gd xs1 xs2 vs1 vs2 r1 r2 s1 s2 vm1 : check_lvals xs1 xs2 r1 = ok r2 -> eq_alloc r1 s1.(evm) vm1 -> List.Forall2 value_uincl vs1 vs2 -> - write_lvals gd s1 xs1 vs1 = ok s2 -> - exists vm2, - write_lvals gd (with_vm s1 vm1) xs2 vs2 = ok (with_vm s2 vm2) /\ + write_lvals wdb gd s1 xs1 vs1 = ok s2 -> + exists2 vm2, + write_lvals wdb gd (with_vm s1 vm1) xs2 vs2 = ok (with_vm s2 vm2) & eq_alloc r2 s2.(evm) vm2. Proof. elim: xs1 xs2 vs1 vs2 r1 r2 s1 s2 vm1 => [ | x1 xs1 Hrec] [ | x2 xs2] //= vs1 vs2 r1 r2 s1 s2 vm1. + by move=> [<-] Hvm1 [] //= [<-];exists vm1. - apply: rbindP => r3 Hx Hcxs Hvm1 [] //= {vs1 vs2}. - move=> v1 v2 vs1 vs2 Hv Hvs;apply: rbindP => s3 Hw Hws. - have [ //| vm3 [->/= Hvm3]] := check_lvalP (e2:= None) Hx Hvm1 Hv _ Hw. + t_xrbindP => r3 Hx Hcxs Hvm1 [] //= {vs1 vs2} v1 v2 vs1 vs2 Hv Hvs. + t_xrbindP => s3 Hw Hws. + have [//| vm3 ->/= Hvm3] := check_lvalP (e2:= None) Hx Hvm1 Hv _ Hw. apply: Hrec Hcxs Hvm3 Hvs Hws. Qed. @@ -625,34 +480,30 @@ Section PROOF. Proof. move => s1 s2 t o xs es. rewrite /sem_sopn; t_xrbindP => v ves He Ho Hw r1 [] //= xs2 t' o2 es2 r2 vm1 Hvm1. - rewrite /check_i. - case:ifPn => //= /eqP <-. - t_xrbindP => r1' /check_esP -/(_ _ _ Hvm1) [Hr1'] /(_ _ He) [v2 [He2 Hu2]]. + rewrite /check_i; t_xrbindP => r1' /eqP <- /check_esP -/(_ true _ _ Hvm1) [Hr1'] /(_ _ He) [v2 [He2 Hu2]]. have [v' Ho' Hv Hcxs]:= vuincl_exec_opn Hu2 Ho. - have /(_ _ Hr1') [vm2 [Hwv Hvm2]]:= check_lvalsP Hcxs _ Hv Hw. - by exists vm2;split=>//;constructor;rewrite /sem_sopn He2 /= Ho' -eq_globs. + have /(_ _ Hr1') [vm2 Hwv Hvm2]:= check_lvalsP Hcxs _ Hv Hw. + by exists vm2 =>//; constructor; rewrite /sem_sopn He2 /= Ho' -eq_globs. Qed. Local Lemma Hsyscall : sem_Ind_syscall p1 Pi_r. Proof. move => s1 scs m s2 o xs es ves vs hes hsys hw r1 [] //= xs2 o2 es2 r2 vm1 Hvm1. - rewrite /check_i. - case:ifPn => //= /eqP <-. - t_xrbindP => r1' /check_esP -/(_ _ _ Hvm1) [Hr1'] /(_ _ hes) [v2 [He2 Hu2]] Hcxs. + rewrite /check_i; t_xrbindP => r1'/eqP <- /check_esP -/(_ true _ _ Hvm1) [Hr1'] /(_ _ hes) [v2 [He2 Hu2]] Hcxs. have [vs' Ho' Hv] := exec_syscallP hsys Hu2. - have /(_ _ Hr1') [vm2 [Hwv Hvm2]]:= check_lvalsP Hcxs _ Hv hw. - by exists vm2;split=>//; econstructor; eauto; rewrite -eq_globs. + have /(_ _ Hr1') [vm2 Hwv Hvm2]:= check_lvalsP Hcxs _ Hv hw. + by exists vm2 => //; econstructor; eauto; rewrite -eq_globs. Qed. Local Lemma Hif_true : sem_Ind_if_true p1 ev Pc Pi_r. Proof. move => s1 s2 e c1 c2. case: s1 => scs1 sm1 svm1 Hve _ Hc1 r1 [] //= e' c1' c2' r2 vm1 Hvm1. - rewrite /check_i. - t_xrbindP => r1' /check_eP -/(_ gd _ _ Hvm1) [] Hr1'. + rewrite /check_i -/check_I. + t_xrbindP => r1' /check_eP -/(_ true gd _ _ Hvm1) [] Hr1'. move=> /(_ _ _ _ Hve) [ve' [Hve' /value_uinclE ?]];subst ve'. move => r3 Hr3 r4 Hr4 <-. - have [vm2 [Hvm2 Hsem]]:= Hc1 _ _ _ _ Hr1' Hr3;exists vm2;split. + have [vm2 Hvm2 Hsem]:= Hc1 _ _ _ _ Hr1' Hr3;exists vm2. + by eapply eq_alloc_incl;eauto;apply M.merge_incl_l. by apply Eif_true => //;rewrite -eq_globs Hve'. Qed. @@ -661,11 +512,11 @@ Section PROOF. Proof. move => s1 s2 e c1 c2. case: s1 => scs1 sm1 svm1 Hve _ Hc1 r1 [] //= e' c1' c2' r2 vm1 Hvm1. - rewrite /check_i. - t_xrbindP => r1' /check_eP -/(_ gd _ _ Hvm1) [] Hr1'. + rewrite /check_i -/check_I. + t_xrbindP => r1' /check_eP -/(_ true gd _ _ Hvm1) [] Hr1'. move=> /(_ _ _ _ Hve) [ve' [Hve' /value_uinclE ?]];subst ve'. move => r3 Hr3 r4 Hr4 <-. - have [vm2 [Hvm2 Hsem]]:= Hc1 _ _ _ _ Hr1' Hr4;exists vm2;split. + have [vm2 Hvm2 Hsem]:= Hc1 _ _ _ _ Hr1' Hr4;exists vm2. + by eapply eq_alloc_incl;eauto;apply M.merge_incl_r. by apply Eif_false => //;rewrite -eq_globs Hve'. Qed. @@ -689,14 +540,14 @@ Section PROOF. rewrite /check_i -/check_I. apply: rbindP => r /loop2P [r2' [r3 [H Hir1 Hir3]]] [?];subst r. have Hvmr2' := eq_alloc_incl Hir1 Hvm1. - move: H; t_xrbindP => r0 Cc2; move /Hc: (Hvmr2') (Cc2) => H /H {H} [vm2 [Hvm2 /= Hc2]] re Hre. - have /= [Hrevm2 /(_ _ _ _ Hse) [vb' [Hse2 /value_uinclE ?]]]:= check_eP gd Hre Hvm2. + move: H; t_xrbindP => r0 Cc2; move /Hc: (Hvmr2') (Cc2) => H /H {H} [vm2 Hvm2 /= Hc2] re Hre. + have /= [Hrevm2 /(_ _ _ _ Hse) [vb' [Hse2 /value_uinclE ?]]]:= check_eP true gd Hre Hvm2. subst vb' => r' Cc2' ??;subst r2 r3. - move /Hc': (Hrevm2) (Cc2')=> H /H {H} [vm3 [Hvm3 /= Hc2']]. + move /Hc': (Hrevm2) (Cc2')=> H /H {H} [vm3 Hvm3 /= Hc2']. have /Hw {Hw} Hw:= eq_alloc_incl Hir3 Hvm3. have : check_i (Cwhile a c e c') (Cwhile a2 c2 e2 c2') r2' = ok re. + by rewrite /check_i -/check_I Loop.nbP /= Cc2 /= Hre /= Cc2' /= Hir3 /=. - move=> /Hw [vm4 [Hvm4 Hsw]];exists vm4;split => //. + move=> /Hw [vm4 Hvm4 Hsw];exists vm4 => //. by apply: Ewhile_true Hsw;eauto;rewrite -eq_globs Hse2. Qed. @@ -707,10 +558,9 @@ Section PROOF. rewrite /check_i -/check_I. t_xrbindP => r /loop2P [r2' [r3 [H Hir1 Hir3]]] ?;subst r. have Hvmr2' := eq_alloc_incl Hir1 Hvm1. - move: H; t_xrbindP=> r0 Cc2; move /Hc: (Hvmr2') (Cc2) => H /H {H} [vm2 [Hvm2 /= Hc2]] re Hre. - have /= [Hrevm2 /(_ _ _ _ Hse) [vb' [Hse2 /value_uinclE ?]]]:= check_eP gd Hre Hvm2. - subst vb' => r' Cc2' ??;subst r2 r3. - exists vm2;split => //. + move: H; t_xrbindP=> r0 Cc2; move /Hc: (Hvmr2') (Cc2) => H /H {H} [vm2 Hvm2 /= Hc2] re Hre. + have /= [Hrevm2 /(_ _ _ _ Hse) [vb' [Hse2 /value_uinclE ?]]]:= check_eP true gd Hre Hvm2. + subst vb' => r' Cc2' ??;subst r2 r3; exists vm2 => //. by apply: Ewhile_false;rewrite // -eq_globs Hse2. Qed. @@ -729,44 +579,39 @@ Section PROOF. Local Lemma Hfor : sem_Ind_for p1 ev Pi_r Pfor. Proof. move => s1 s2 i d lo hi c vlo vhi. - case: s1 => scs1 sm1 svm1. - move=> Hlo Hhi Hc Hfor r1 [] //= i2 [[d2 lo2] hi2] c2 r2 vm1 Hvm1. + case: s1 => scs1 sm1 svm1 Hlo Hhi Hc Hfor r1 [] //= i2 [[d2 lo2] hi2] c2 r2 vm1 Hvm1. rewrite /check_i -/check_I. case: eqP => //= ?;subst d2. - t_xrbindP => r1' r1'' /check_eP -/(_ gd _ _ Hvm1) [Hr1'' Heqlo]. + t_xrbindP => r1' r1'' /check_eP -/(_ true gd _ _ Hvm1) [Hr1'' Heqlo]. have [vlo'' [Hlo2 /value_uinclE Hvlo']] := Heqlo _ _ _ Hlo. - subst vlo'' => /check_eP -/(_ gd _ _ Hr1'') [Hr1' Heqhi]. + subst vlo'' => /check_eP -/(_ true gd _ _ Hr1'') [Hr1' Heqhi]. have [vhi'' [Hhi2 /value_uinclE Hhi']] := Heqhi _ _ _ Hhi. subst vhi'' => /loopP [r2'] []; t_xrbindP=> r2'' Hcv Hcc Hr2r1 Hr2r2. have := Hfor _ _ _ _ _ _ (eq_alloc_incl Hr2r1 Hr1') Hcv Hcc Hr2r2. - move=> [vm2 [Hvm2 Hsem2]];exists vm2;split=> //. + move=> [vm2 Hvm2 Hsem2];exists vm2 => //. econstructor; rewrite -?eq_globs ?Hlo2 ?Hhi2 /= ;eauto. Qed. Local Lemma Hfor_nil : sem_Ind_for_nil Pfor. - Proof. - by move=> s i c i2 r1 r1' c2 r2 vm1 Ha ???;exists vm1;split=> //;constructor. - Qed. + Proof. by move=> s i c i2 r1 r1' c2 r2 vm1 Ha ???;exists vm1 => //;constructor. Qed. Local Lemma Hfor_cons : sem_Ind_for_cons p1 ev Pc Pfor. Proof. move=> s1 s1' s2 s3 i w ws c Hwi _ Hc _ Hfor i2 r1 r1' c2 r2 vm2 Heq Hr1' Hcc Hincl. - have [//|vm3 [Hwi2 Hvm3]] := check_lvalP (gd := gd) Hr1' Heq (value_uincl_refl _) _ Hwi. - have [vm4 [Hvm4 Hsc]] := Hc _ _ _ _ Hvm3 Hcc. - have [vm5 [Hvm5 Hsf]] := Hfor _ _ _ _ _ _ (eq_alloc_incl Hincl Hvm4) Hr1' Hcc Hincl. - by exists vm5;split=>//;econstructor;eauto. + have [//|vm3 Hwi2 Hvm3] := check_lvalP (gd := gd) Hr1' Heq (value_uincl_refl _) _ Hwi. + have [vm4 Hvm4 Hsc] := Hc _ _ _ _ Hvm3 Hcc. + have [vm5 Hvm5 Hsf] := Hfor _ _ _ _ _ _ (eq_alloc_incl Hincl Hvm4) Hr1' Hcc Hincl. + by exists vm5 => //; econstructor; eauto. Qed. Local Lemma Hcall : sem_Ind_call p1 ev Pi_r Pfun. Proof. move=> s1 scs2 m2 s2 ii xs fn args vargs vs Hes Hsc Hfun Hw r1 [] //= ii2 xs2 fn2 args2 r2 vm1 Hr1. - rewrite /check_i. - case: eqP => //= ?;subst fn2. - apply: rbindP => r1' Hca Hcxs. - have [Hr1' /(_ _ Hes) [vargs2 [Hargs2 Hvargs]]] := check_esP Hca Hr1. - have [v' [Hs2 Hvs]]:= Hfun _ Hvargs. - have /(_ _ Hr1') [vm2 [Hw2 Hr2]]:= check_lvalsP Hcxs _ Hvs Hw. - exists vm2;split=>//. by econstructor;eauto;rewrite -?eq_globs. + rewrite /check_i -/check_I; t_xrbindP => r1' /eqP ? Hca Hcxs; subst fn2. + have [Hr1' /(_ _ Hes) [vargs2 [Hargs2 Hvargs]]] := check_esP (~~direct_call) Hca Hr1. + have [v' Hs2 Hvs]:= Hfun _ Hvargs. + have /(_ _ Hr1') [vm2 Hw2 Hr2]:= check_lvalsP Hcxs _ Hvs Hw. + by exists vm2 =>//; econstructor;eauto;rewrite -?eq_globs. Qed. Section REFL. @@ -775,60 +620,59 @@ Section PROOF. Local Lemma Hproc_eq scs1 m1 scs2 m2 fn f vargs vargs' s0 s1 s2 vres vres': get_fundef (p_funcs p1) fn = Some f -> - mapM2 ErrType truncate_val f.(f_tyin) vargs' = ok vargs -> - init_state f.(f_extra) (p_extra p1) ev (Estate scs1 m1 vmap0) = ok s0 -> - write_vars (f_params f) vargs s0 = ok s1 -> + mapM2 ErrType dc_truncate_val f.(f_tyin) vargs' = ok vargs -> + init_state f.(f_extra) (p_extra p1) ev (Estate scs1 m1 Vm.init) = ok s0 -> + write_vars (~~direct_call) (f_params f) vargs s0 = ok s1 -> sem p1 ev s1 (f_body f) s2 -> Pc s1 (f_body f) s2 -> - mapM (fun x : var_i => get_var s2.(evm) x) (f_res f) = ok vres -> - mapM2 ErrType truncate_val f.(f_tyout) vres = ok vres' -> + mapM (fun x : var_i => get_var (~~direct_call) s2.(evm) x) (f_res f) = ok vres -> + mapM2 ErrType dc_truncate_val f.(f_tyout) vres = ok vres' -> scs2 = s2.(escs) -> m2 = finalize f.(f_extra) s2.(emem) -> Pfun scs1 m1 fn vargs' scs2 m2 vres'. Proof. move=> Hget Hca Hi Hw Hsem _ Hres Hcr hscs Hfi vargs2 Hvargs2; rewrite -eq_prog. - have: sem_call p1 ev scs1 m1 fn vargs' scs2 m2 vres' by econstructor;eauto. - by apply: sem_call_uincl. + have h : sem_call p1 ev scs1 m1 fn vargs' scs2 m2 vres' by econstructor;eauto. + have [?[]]:= sem_call_uincl Hvargs2 h; eauto. Qed. Lemma alloc_funP_eq_aux fn f f' scs1 m1 scs2 m2 vargs vargs' vres s0 s1 s2 vres': check_fundef ep1 ep2 (fn, f) (fn, f') tt = ok tt -> - mapM2 ErrType truncate_val f.(f_tyin) vargs' = ok vargs -> - init_state f.(f_extra) (p_extra p1) ev (Estate scs1 m1 vmap0) = ok s0 -> - write_vars (f_params f) vargs s0 = ok s1 -> + mapM2 ErrType dc_truncate_val f.(f_tyin) vargs' = ok vargs -> + init_state f.(f_extra) (p_extra p1) ev (Estate scs1 m1 Vm.init) = ok s0 -> + write_vars (~~direct_call) (f_params f) vargs s0 = ok s1 -> sem p1 ev s1 (f_body f) s2 -> - mapM (fun x : var_i => get_var (evm s2) x) (f_res f) = ok vres -> - mapM2 ErrType truncate_val f.(f_tyout) vres = ok vres' -> + mapM (fun x : var_i => get_var (~~direct_call) (evm s2) x) (f_res f) = ok vres -> + mapM2 ErrType dc_truncate_val f.(f_tyout) vres = ok vres' -> scs2 = s2.(escs) -> m2 = finalize f.(f_extra) s2.(emem) -> exists vm0' vm1' vm2' vres1 vres1', - [ /\ mapM2 ErrType truncate_val f'.(f_tyin) vargs' = ok vargs, - init_state f'.(f_extra) (p_extra p2) ev (Estate scs1 m1 vmap0) = ok (with_vm s0 vm0') /\ - write_vars (f_params f') vargs (with_vm s0 vm0') = ok (with_vm s1 vm1'), + [ /\ mapM2 ErrType dc_truncate_val f'.(f_tyin) vargs' = ok vargs, + init_state f'.(f_extra) (p_extra p2) ev (Estate scs1 m1 Vm.init) = ok (with_vm s0 vm0') /\ + write_vars (~~direct_call) (f_params f') vargs (with_vm s0 vm0') = ok (with_vm s1 vm1'), sem p2 ev (with_vm s1 vm1') (f_body f') (with_vm s2 vm2'), - [ /\ mapM (fun x : var_i => get_var (evm (with_vm s2 vm2')) x) (f_res f') = ok vres1, + [ /\ mapM (fun x : var_i => get_var (~~direct_call) (evm (with_vm s2 vm2')) x) (f_res f') = ok vres1, List.Forall2 value_uincl vres' vres1' & - mapM2 ErrType truncate_val f'.(f_tyout) vres1 = ok vres1'] & + mapM2 ErrType dc_truncate_val f'.(f_tyout) vres1 = ok vres1'] & scs2 = s2.(escs) /\ m2 = finalize f'.(f_extra) s2.(emem) ]. Proof. rewrite /check_fundef eq_refl => /=. - case: ifP => // /andP[]/andP[]/eqP htyin /eqP htyout /eqP hextra. - t_xrbindP => r0 Hcinit r1 Hcparams r2 Hcc r3 Hcres _ Hca. + t_xrbindP => /and3P[]/eqP htyin /eqP htyout /eqP hextra r0 Hcinit r1 Hcparams r2 Hcc r3 Hcres _ Hca. move=> /(init_allocP Hcinit) [vm0 [Hi0 Hvm0]]. - rewrite (write_vars_lvals gd)=> /(check_lvalsP Hcparams). - move=> /(_ vargs _ Hvm0) [ | vm3 /= [Hw2 Hvm3]]. + rewrite (write_vars_lvals (~~direct_call) gd)=> /(check_lvalsP Hcparams). + move=> /(_ vargs _ Hvm0) [ | vm3 /= Hw2 Hvm3]. + by apply: List_Forall2_refl. move=> /(sem_Ind Hskip Hcons HmkI Hassgn Hopn Hsyscall Hif_true Hif_false Hwhile_true Hwhile_false Hfor Hfor_nil Hfor_cons Hcall Hproc_eq) Hc. - have [vm4 /= [Hvm4 Hsc2] Hres Hcr]:= Hc _ _ _ _ Hvm3 Hcc. - have := check_esP Hcres Hvm4. + have [vm4 /= Hvm4 Hsc2 Hres Hcr]:= Hc _ _ _ _ Hvm3 Hcc. + have := check_esP (~~direct_call) Hcres Hvm4. move=> [Hr3];rewrite sem_pexprs_get_var => /(_ _ Hres) [vres1' /= []]. rewrite sem_pexprs_get_var => hmap huincl ??. - have [vres2' ??]:= mapM2_truncate_val Hcr huincl. + have [vres2' ??]:= mapM2_dc_truncate_val Hcr huincl. do 5 eexists;split;eauto. + by rewrite -htyin. + rewrite -hextra; split; first by eauto. - by rewrite (write_vars_lvals gd). + by rewrite (write_vars_lvals _ gd). + by rewrite -htyout;split;eauto. by rewrite -hextra. Qed. @@ -839,23 +683,22 @@ Section PROOF. Proof. move=> scs1 m1 scs2 m2 fn f vargs vargs' s0 s1 s2 vres vres' Hget Hca Hi Hw _ Hc Hres Hcr Hscs Hfi. have [fd2 [Hget2 /=]]:= all_checked Hget. - rewrite eq_refl /=;case: ifP => // /andP[]/andP[] /eqP htyin /eqP htyout /eqP hextra. - t_xrbindP => r0 Hcinit r1 Hcparams r2 Hcc r3 Hcres _. + t_xrbindP => /and4P [] _ /eqP htyin /eqP htyout /eqP hextra r0 Hcinit r1 Hcparams r2 Hcc r3 Hcres _. move=> vargs2 Hvargs2. have [vm0 [Hi0 Hvm0]]:= init_allocP Hcinit Hi. - have [vs2 htr hall2]:= mapM2_truncate_val Hca Hvargs2. - move: Hw;rewrite (write_vars_lvals gd)=> /(check_lvalsP Hcparams). - move=> /(_ _ _ Hvm0 hall2) [vm3 /= [Hw2 Hvm3]]. - have [vm4 /= [Hvm4 Hsc2]]:= Hc _ _ _ _ Hvm3 Hcc. - have := check_esP Hcres Hvm4. + have [vs2 htr hall2]:= mapM2_dc_truncate_val Hca Hvargs2. + move: Hw;rewrite (write_vars_lvals _ gd)=> /(check_lvalsP Hcparams). + move=> /(_ _ _ Hvm0 hall2) [vm3 /= Hw2 Hvm3]. + have [vm4 /= Hvm4 Hsc2]:= Hc _ _ _ _ Hvm3 Hcc. + have := check_esP (~~direct_call) Hcres Hvm4. move=> [Hr3];rewrite sem_pexprs_get_var => /(_ _ Hres) [vres1' /= []]. rewrite sem_pexprs_get_var => H1 H2. - have [vs3 ??]:= mapM2_truncate_val Hcr H2. - econstructor;split;eauto. + have [vs3 ??]:= mapM2_dc_truncate_val Hcr H2. + econstructor;eauto. econstructor;eauto. + by rewrite -htyin; eauto. + by rewrite -hextra; eauto. - + by rewrite (write_vars_lvals gd). + + by rewrite (write_vars_lvals (~~direct_call) gd). + by rewrite -htyout. by rewrite -hextra. Qed. @@ -865,7 +708,7 @@ Section PROOF. exists vr', sem_call p2 ev scs mem f va scs' mem' vr' /\ List.Forall2 value_uincl vr vr'. Proof. move=> h. - apply: + have [|]:= (sem_call_Ind Hskip Hcons @@ -882,7 +725,7 @@ Section PROOF. Hfor_cons Hcall Hproc - h). + h va); eauto. by apply List_Forall2_refl. Qed. @@ -899,22 +742,22 @@ Qed. Lemma alloc_funP_eq p ev fn f f' scs1 m1 scs2 m2 vargs vargs' vres vres' s0 s1 s2: check_fundef (p_extra p) (p_extra p) (fn, f) (fn, f') tt = ok tt -> - mapM2 ErrType truncate_val f.(f_tyin) vargs' = ok vargs -> - init_state (f_extra f) (p_extra p) ev (Estate scs1 m1 vmap0) = ok s0 -> - write_vars (f_params f) vargs s0 = ok s1 -> + mapM2 ErrType dc_truncate_val f.(f_tyin) vargs' = ok vargs -> + init_state (f_extra f) (p_extra p) ev (Estate scs1 m1 Vm.init) = ok s0 -> + write_vars (~~direct_call) (f_params f) vargs s0 = ok s1 -> sem p ev s1 (f_body f) s2 -> - mapM (fun x : var_i => get_var (evm s2) x) (f_res f) = ok vres -> - mapM2 ErrType truncate_val f.(f_tyout) vres = ok vres' -> + mapM (fun x : var_i => get_var (~~direct_call) (evm s2) x) (f_res f) = ok vres -> + mapM2 ErrType dc_truncate_val f.(f_tyout) vres = ok vres' -> scs2 = s2.(escs) -> m2 = finalize f.(f_extra) s2.(emem) -> exists vm0' vm1' vm2' vres1 vres1', - [ /\ mapM2 ErrType truncate_val f'.(f_tyin) vargs' = ok vargs, - init_state f'.(f_extra) (p_extra p) ev (Estate scs1 m1 vmap0) = ok (with_vm s0 vm0') /\ - write_vars (f_params f') vargs (with_vm s0 vm0') = ok (with_vm s1 vm1'), + [ /\ mapM2 ErrType dc_truncate_val f'.(f_tyin) vargs' = ok vargs, + init_state f'.(f_extra) (p_extra p) ev (Estate scs1 m1 Vm.init) = ok (with_vm s0 vm0') /\ + write_vars (~~direct_call) (f_params f') vargs (with_vm s0 vm0') = ok (with_vm s1 vm1'), sem p ev (with_vm s1 vm1') (f_body f') (with_vm s2 vm2'), - [ /\ mapM (fun x : var_i => get_var (evm (with_vm s2 vm2')) x) (f_res f') = ok vres1, + [ /\ mapM (fun x : var_i => get_var (~~direct_call) (evm (with_vm s2 vm2')) x) (f_res f') = ok vres1, List.Forall2 value_uincl vres' vres1' & - mapM2 ErrType truncate_val f'.(f_tyout) vres1 = ok vres1'] & + mapM2 ErrType dc_truncate_val f'.(f_tyout) vres1 = ok vres1'] & scs2 = s2.(escs) /\ m2 = finalize f'.(f_extra) s2.(emem) ]. Proof. by apply alloc_funP_eq_aux. Qed. @@ -928,12 +771,12 @@ Existing Instance progUnit. Lemma init_alloc_uprogP : forall (ef: extra_fun_t) (ep1 ep2: extra_prog_t) ev s1 scs m r, init_alloc_uprog ef ep1 ep2 = ok r -> - init_state ef ep1 ev (Estate scs m vmap0) = ok s1 -> + init_state ef ep1 ev (Estate scs m Vm.init) = ok s1 -> exists vm2, - init_state ef ep2 ev (Estate scs m vmap0) = ok (with_vm s1 vm2) /\ + init_state ef ep2 ev (Estate scs m Vm.init) = ok (with_vm s1 vm2) /\ eq_alloc r s1.(evm) vm2. Proof. - by move=> /= ??? _ ???? [<-] [<-]; exists vmap0; split => //=; apply eq_alloc_empty. + by move=> /= ??? _ ???? [<-] [<-]; exists Vm.init; split => //=; apply eq_alloc_empty. Qed. Lemma alloc_call_uprogP ev gd ep1 p1 ep2 p2 @@ -946,22 +789,22 @@ Proof. by apply: (alloc_callP init_alloc_uprogP). Qed. Lemma alloc_fun_uprogP_eq p ev fn f f' scs1 m1 scs2 m2 vargs vargs' vres vres' s0 s1 s2: check_fundef init_alloc_uprog (p_extra p) (p_extra p) (fn, f) (fn, f') tt = ok tt -> - mapM2 ErrType truncate_val f.(f_tyin) vargs' = ok vargs -> - init_state (f_extra f) (p_extra p) ev (Estate scs1 m1 vmap0) = ok s0 -> - write_vars (f_params f) vargs s0 = ok s1 -> + mapM2 ErrType dc_truncate_val f.(f_tyin) vargs' = ok vargs -> + init_state (f_extra f) (p_extra p) ev (Estate scs1 m1 Vm.init) = ok s0 -> + write_vars (~~direct_call) (f_params f) vargs s0 = ok s1 -> sem p ev s1 (f_body f) s2 -> - mapM (fun x : var_i => get_var (evm s2) x) (f_res f) = ok vres -> - mapM2 ErrType truncate_val f.(f_tyout) vres = ok vres' -> + mapM (fun x : var_i => get_var (~~direct_call) (evm s2) x) (f_res f) = ok vres -> + mapM2 ErrType dc_truncate_val f.(f_tyout) vres = ok vres' -> scs2 = s2.(escs) -> m2 = finalize f.(f_extra) s2.(emem) -> exists vm0' vm1' vm2' vres1 vres1', - [ /\ mapM2 ErrType truncate_val f'.(f_tyin) vargs' = ok vargs, - init_state f'.(f_extra) (p_extra p) ev (Estate scs1 m1 vmap0) = ok (with_vm s0 vm0') /\ - write_vars (f_params f') vargs (with_vm s0 vm0') = ok (with_vm s1 vm1'), + [ /\ mapM2 ErrType dc_truncate_val f'.(f_tyin) vargs' = ok vargs, + init_state f'.(f_extra) (p_extra p) ev (Estate scs1 m1 Vm.init) = ok (with_vm s0 vm0') /\ + write_vars (~~direct_call) (f_params f') vargs (with_vm s0 vm0') = ok (with_vm s1 vm1'), sem p ev (with_vm s1 vm1') (f_body f') (with_vm s2 vm2'), - [ /\ mapM (fun x : var_i => get_var (evm (with_vm s2 vm2')) x) (f_res f') = ok vres1, + [ /\ mapM (fun x : var_i => get_var (~~direct_call) (evm (with_vm s2 vm2')) x) (f_res f') = ok vres1, List.Forall2 value_uincl vres' vres1' & - mapM2 ErrType truncate_val f'.(f_tyout) vres1 = ok vres1'] & + mapM2 ErrType dc_truncate_val f'.(f_tyout) vres1 = ok vres1'] & scs2 = s2.(escs) /\ m2 = finalize f'.(f_extra) s2.(emem) ]. Proof. by apply (alloc_funP_eq_aux init_alloc_uprogP). Qed. @@ -975,14 +818,14 @@ Existing Instance progStack. Lemma init_alloc_sprogP : forall (ef: extra_fun_t) (ep1 ep2: extra_prog_t) ev s1 scs m r, init_alloc_sprog ef ep1 ep2 = ok r -> - init_state ef ep1 ev (Estate scs m vmap0) = ok s1 -> + init_state ef ep1 ev (Estate scs m Vm.init) = ok s1 -> exists vm2, - init_state ef ep2 ev (Estate scs m vmap0) = ok (with_vm s1 vm2) /\ + init_state ef ep2 ev (Estate scs m Vm.init) = ok (with_vm s1 vm2) /\ eq_alloc r s1.(evm) vm2. Proof. rewrite /init_alloc_sprog /init_state /= /init_stk_state /check_vars. - t_xrbindP => ef ep1 ep2 ev s1 scs m r hc m' ha; rewrite (@write_vars_lvals _ _ _ [::]) => hw. - have [ vm2 [] ]:= check_lvalsP (s1 := (Estate scs m' vmap0)) hc eq_alloc_empty + t_xrbindP => ef ep1 ep2 ev s1 scs m r hc m' ha; rewrite (@write_vars_lvals _ _ _ _ _ [::]) => hw. + have [vm2 ]:= check_lvalsP (s1 := (Estate scs m' Vm.init)) hc eq_alloc_empty (List_Forall2_refl _ (@value_uincl_refl)) hw. rewrite ha -write_vars_lvals => ??. by exists vm2. diff --git a/proofs/compiler/arch_params_proof.v b/proofs/compiler/arch_params_proof.v index 21207f0d3..f7ca804bd 100644 --- a/proofs/compiler/arch_params_proof.v +++ b/proofs/compiler/arch_params_proof.v @@ -25,6 +25,8 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. +#[local] Existing Instance withsubword. +#[local] Existing Instance direct_c. Record h_lowering_params {syscall_state : Type} {sc_sem : syscall.syscall_sem syscall_state} @@ -47,7 +49,7 @@ Record h_lowering_params (scs: syscall_state_t) (mem : low_memory.mem) (scs': syscall_state_t) (mem' : low_memory.mem) (va vr : seq value), - sem_call p ev scs mem f va scs' mem' vr + sem_call (dc:= direct_c) p ev scs mem f va scs' mem' vr -> let lprog := lowering.lower_prog (lop_lower_i loparams) diff --git a/proofs/compiler/arm_instr_decl_lemmas.v b/proofs/compiler/arm_instr_decl_lemmas.v index d9583d837..3e13972c3 100644 --- a/proofs/compiler/arm_instr_decl_lemmas.v +++ b/proofs/compiler/arm_instr_decl_lemmas.v @@ -35,9 +35,8 @@ Proof. by case: mn. Qed. Section WITH_PARAMS. - - Context + {wsw : WithSubWord} {atoI : arch_toIdent} {syscall_state : Type} {sc_sem : syscall_sem syscall_state} @@ -107,20 +106,20 @@ Qed. (* TODO_ARM: Is this the best way of expressing the [write_val] condition? *) Lemma sem_i_conditional - (p : prog) + {dc : DirectCall} (p : prog) ev s0 s1 mn sf osk lvs tag args c prev vargs b vprev vprev' vres : let opts := {| set_flags := sf; is_conditional := false; has_shift := osk; |} in let aop := Oarm (ARM_op mn opts) in - sem_pexprs (p_globs p) s0 args = ok vargs - -> sem_pexpr (p_globs p) s0 c = ok (Vbool b) - -> sem_pexprs (p_globs p) s0 prev = ok vprev + sem_pexprs true (p_globs p) s0 args = ok vargs + -> sem_pexpr true (p_globs p) s0 c = ok (Vbool b) + -> sem_pexprs true (p_globs p) s0 prev = ok vprev -> truncate_args aop vprev = ok vprev' -> exec_sopn aop vargs = ok vres -> (if b - then write_lvals (p_globs p) s0 lvs vres = ok s1 - else write_lvals (p_globs p) s0 lvs vprev' = ok s1) + then write_lvals true (p_globs p) s0 lvs vres = ok s1 + else write_lvals true (p_globs p) s0 lvs vprev' = ok s1) -> let aop' := Oarm (ARM_op mn (set_is_conditional opts)) in let ir := Copn lvs tag aop' (args ++ c :: prev) in sem_i p ev s0 ir s1. @@ -129,7 +128,7 @@ Proof. apply: Eopn. rewrite /sem_sopn /=. - rewrite /sem_pexprs mapM_cat /= -2![mapM _ _]/(sem_pexprs _ _ _). + rewrite /sem_pexprs mapM_cat /= -2![mapM _ _]/(sem_pexprs _ _ _ _). rewrite hsemargs hsemc hsemprev {hsemargs hsemc hsemprev} /=. case: b hwrite => hwrite. diff --git a/proofs/compiler/arm_lowering_proof.v b/proofs/compiler/arm_lowering_proof.v index 3b216ca45..aff106336 100644 --- a/proofs/compiler/arm_lowering_proof.v +++ b/proofs/compiler/arm_lowering_proof.v @@ -56,6 +56,8 @@ Qed. Section PROOF. Context + {wsw : WithSubWord} + {dc : DirectCall} {atoI : arch_toIdent} {syscall_state : Type} {sc_sem : syscall_sem syscall_state} @@ -128,10 +130,10 @@ Definition estate_of_CMP s (w0 w1 : wreg) : estate := let res_signed := (wsigned w0 + wsigned w1not + 1)%Z in let vm' := (evm s) - .[fvNF fv <- ok (NF_of_word res)] - .[fvZF fv <- ok (ZF_of_word res)] - .[fvCF fv <- ok (wunsigned res != res_unsigned)] - .[fvVF fv <- ok (wsigned res != res_signed)]%vmap + .[fvNF fv <- NF_of_word res] + .[fvZF fv <- ZF_of_word res] + .[fvCF fv <- wunsigned res != res_unsigned] + .[fvVF fv <- wsigned res != res_signed] in with_vm s vm'. @@ -139,9 +141,9 @@ Definition estate_of_TST s (w0 w1 : wreg) : estate := let res := wand w0 w1 in let vm' := (evm s) - .[fvNF fv <- ok (NF_of_word res)] - .[fvZF fv <- ok (ZF_of_word res)] - .[fvCF fv <- ok false]%vmap + .[fvNF fv <- NF_of_word res] + .[fvZF fv <- ZF_of_word res] + .[fvCF fv <- false] in with_vm s vm'. @@ -161,7 +163,7 @@ Proof. case: mn => // _. all: split => // x hx. all: rewrite /=. - all: rewrite !Fv.setP_neq; first reflexivity. + all: rewrite !Vm.setP_neq; first reflexivity. all: apply/eqP. all: move=> ?; subst x. @@ -174,7 +176,7 @@ Lemma sem_condition_mn ii tag mn s es ws0 ws1 (w0 : word ws0) (w1 : word ws1) : mn \in condition_mnemonics -> (reg_size <= ws0)%CMP -> (reg_size <= ws1)%CMP - -> sem_pexprs (p_globs p) s es = ok [:: Vword w0; Vword w1 ] + -> sem_pexprs true (p_globs p) s es = ok [:: Vword w0; Vword w1 ] -> let w0' := zero_extend reg_size w0 in let w1' := zero_extend reg_size w1 in let aop := Oarm (ARM_op mn default_opts) in @@ -207,8 +209,8 @@ Qed. Lemma lower_condition_Papp2P s op e0 e1 mn e es v0 v1 v : lower_condition_Papp2 fv op e0 e1 = Some (mn, e, es) - -> sem_pexpr (p_globs p) s e0 = ok v0 - -> sem_pexpr (p_globs p) s e1 = ok v1 + -> sem_pexpr true (p_globs p) s e0 = ok v0 + -> sem_pexpr true (p_globs p) s e1 = ok v1 -> sem_sop2 op v0 v1 = ok v -> exists (ws0 ws1 : wsize) (w0 : word ws0) (w1 : word ws1), let w0' := zero_extend reg_size w0 in @@ -216,8 +218,8 @@ Lemma lower_condition_Papp2P s op e0 e1 mn e es v0 v1 v : [/\ mn \in condition_mnemonics , (reg_size <= ws0)%CMP , (reg_size <= ws1)%CMP - , sem_pexprs (p_globs p) s es = ok [:: Vword w0; Vword w1 ] - & sem_pexpr (p_globs p) (estate_of_condition_mn mn s w0' w1') e = ok v + , sem_pexprs true (p_globs p) s es = ok [:: Vword w0; Vword w1 ] + & sem_pexpr true (p_globs p) (estate_of_condition_mn mn s w0' w1') e = ok v ]. Proof. move=> h hseme0 hseme1 hsemop. @@ -272,7 +274,7 @@ Proof. clear hws00 hws01. rewrite /get_gvar /=. - repeat t_get_var. + repeat t_get_var => //. rewrite wrepr0 zero_extend0. rewrite -(wand_zero_extend _ _ hws0). @@ -288,7 +290,7 @@ Proof. all: clear hws0 hws1. all: rewrite /get_gvar /=. - all: repeat t_get_var. + all: repeat t_get_var => //. (* Case [w0 == w1]. *) - by rewrite wsub_wnot1 -GRing.Theory.subr_eq0. @@ -356,11 +358,11 @@ Lemma sem_lower_condition_pexpr tag s0 s0' ii e v lvs aop es c : lower_condition_pexpr fv e = Some (lvs, aop, es, c) -> eq_fv s0' s0 -> disj_fvars (read_e e) - -> sem_pexpr (p_globs p) s0 e = ok v + -> sem_pexpr true (p_globs p) s0 e = ok v -> exists s1', [/\ sem p' ev s0' [:: MkI ii (Copn lvs tag aop es) ] s1' , eq_fv s1' s0 - & sem_pexpr (p_globs p) s1' c = ok v + & sem_pexpr true (p_globs p) s1' c = ok v ]. Proof. move=> h hs00 hfv hseme. @@ -400,11 +402,11 @@ Lemma sem_lower_condition s0 s0' ii e v pre e' : lower_condition fv e = (pre, e') -> eq_fv s0' s0 -> disj_fvars (read_e e) - -> sem_pexpr (p_globs p) s0 e = ok v + -> sem_pexpr true (p_globs p) s0 e = ok v -> exists s1', [/\ sem p' ev s0' (map (MkI ii) pre) s1' , eq_fv s1' s0 - & sem_pexpr (p_globs p) s1' e' = ok v + & sem_pexpr true (p_globs p) s1' e' = ok v ]. Proof. move=> h hs00 hfv hseme. @@ -434,11 +436,11 @@ Qed. Lemma get_arg_shiftP s e ws w e' sh n : get_arg_shift ws [:: e ] = Some (e', sh, n) -> disj_fvars (read_e e) - -> sem_pexpr (p_globs p) s e = ok w + -> sem_pexpr true (p_globs p) s e = ok w -> exists ws1 (wbase : word ws1) (wsham : word U8), [/\ (ws <= ws1)%CMP - , sem_pexpr (p_globs p) s e' = ok (Vword wbase) - , sem_pexpr (p_globs p) s n = ok (Vword wsham) + , sem_pexpr true (p_globs p) s e' = ok (Vword wbase) + , sem_pexpr true (p_globs p) s n = ok (Vword wsham) , to_word reg_size w = ok (shift_op sh (zero_extend reg_size wbase) (wunsigned wsham)) & (disj_fvars (read_e e') /\ disj_fvars (read_e n)) @@ -544,7 +546,7 @@ Definition ok_lower_pexpr_aux (s : estate) (ws ws' : wsize) (aop : arm_op) (es : seq pexpr) (w : word ws') : Prop := (exists2 vs, - sem_pexprs (p_globs p) s es = ok vs + sem_pexprs true (p_globs p) s es = ok vs & exec_sopn (Oarm aop) vs = ok [:: Vword (zero_extend ws w) ]) /\ inv_lower_pexpr_aux ws aop es. @@ -554,7 +556,7 @@ Definition Plower_pexpr_aux (e : pexpr) : Prop := lower_pexpr_aux ws e = Some (aop, es) -> (ws <= ws')%CMP -> disj_fvars (read_e e) - -> sem_pexpr (p_globs p) s e = ok (Vword w) + -> sem_pexpr true (p_globs p) s e = ok (Vword w) -> ok_lower_pexpr_aux s ws aop es w. Lemma lower_PvarP gx : @@ -584,7 +586,7 @@ Proof. case: e => // [ aa | ] ws x e s ws' ws'' aop es w. all: rewrite /lower_pexpr_aux /lower_load. all: case: ws' => // /Some_inj[] ?? hws hfve; subst aop es. - all: rewrite /sem_pexpr -/(sem_pexpr _ s e). + all: rewrite /sem_pexpr -/(sem_pexpr _ _ s e). - apply: on_arr_gvarP => n t hty ok_t. apply: rbindP => idx. @@ -640,7 +642,7 @@ Proof. move=> s ws ws' aop es w. move=> h hws hfve. - rewrite /sem_pexpr -/(sem_pexpr _ s e). + rewrite /sem_pexpr -/(sem_pexpr _ _ s e). t_xrbindP=> v hseme hw. move: h. @@ -678,7 +680,7 @@ Proof. all: move=> [? ?]; subst aop es. all: split; last done. all: clear hfve. - all: rewrite /= -/(sem_pexpr _ s (Pload _ _ _)). + all: rewrite /= -/(sem_pexpr _ _ s (Pload _ _ _)). all: rewrite hseme {hseme} /=. all: eexists; first reflexivity. all: rewrite /exec_sopn /=. @@ -696,7 +698,7 @@ Proof. all: move=> [? ?]; subst aop es. all: split; last done. all: clear hfve. - all: rewrite /= -/(sem_pexpr _ s (Pload _ _ _)). + all: rewrite /= -/(sem_pexpr _ _ s (Pload _ _ _)). all: rewrite hseme {hseme} /=. all: eexists; first reflexivity. all: rewrite /exec_sopn /=. @@ -786,7 +788,7 @@ Proof. move=> h hws hfve hseme. move: hseme. - rewrite /sem_pexpr -!/(sem_pexpr _ s _). + rewrite /sem_pexpr -!/(sem_pexpr _ _ s _). t_xrbindP=> v0 hseme0 v1 hseme1 hsemop. move: hfve => /disj_fvars_read_e_Papp2 [hfve0 hfve1]. @@ -998,7 +1000,7 @@ Proof. 3: rewrite /sem_shr /sem_shift wshr0. 6: rewrite /sem_sar /sem_shift wsar0. 8: rewrite /sem_ror /sem_shift wror0. - 10, 11: have! := (is_wconstP (p_globs p) s hconst); rewrite hseme1 => /truncate_wordP[] _. + 10, 11: have! := (is_wconstP true (p_globs p) s hconst); rewrite hseme1 => /truncate_wordP[] _. 10: move => <-; rewrite /sem_rol /sem_shift wrol0. 11: { @@ -1032,8 +1034,8 @@ Lemma sem_i_lower_pexpr_aux s0 s1 s0' ws ws' e aop es (w : word ws') lv tag : -> (ws <= ws')%CMP -> disj_fvars (read_e e) -> disj_fvars (vars_lval lv) - -> sem_pexpr (p_globs p) s0 e = ok (Vword w) - -> write_lval (p_globs p) lv (Vword (zero_extend ws w)) s0 = ok s1 + -> sem_pexpr true (p_globs p) s0 e = ok (Vword w) + -> write_lval true (p_globs p) lv (Vword (zero_extend ws w)) s0 = ok s1 -> exists2 s1', sem_i p' ev s0' (Copn [:: lv ] tag (Oarm aop) es) s1' & eq_fv s1' s1. @@ -1071,8 +1073,8 @@ Lemma sem_lower_pexpr -> (ws <= ws')%CMP -> disj_fvars (read_e e) -> disj_fvars (vars_lval lv) - -> sem_pexpr (p_globs p) s0 e = ok (Vword w) - -> write_lval (p_globs p) lv (Vword (zero_extend ws w)) s0 = ok s1 + -> sem_pexpr true (p_globs p) s0 e = ok (Vword w) + -> write_lval true (p_globs p) lv (Vword (zero_extend ws w)) s0 = ok s1 -> exists2 s1', let cmd := map (MkI ii) (pre ++ [:: Copn [:: lv ] tag (Oarm aop) es ]) in sem p' ev s0' cmd s1' & eq_fv s1' s1. @@ -1130,8 +1132,8 @@ Proof. have [s2' hwrite12' hs21] : exists2 s2', (if b - then write_lvals (p_globs p) s1' [:: lv ] vres = ok s2' - else write_lvals (p_globs p) s1' [:: lv ] vprev' = ok s2') + then write_lvals true (p_globs p) s1' [:: lv ] vres = ok s2' + else write_lvals true (p_globs p) s1' [:: lv ] vprev' = ok s2') & eq_fv s2' s1. { case: b hw hsemc' => hw _. @@ -1163,8 +1165,8 @@ Lemma sem_i_lower_store s0 s1 s0' ws ws' e aop es (w : word ws') lv tag : -> eq_fv s0' s0 -> (ws <= ws')%CMP -> disj_fvars (read_e e) - -> sem_pexpr (p_globs p) s0 e = ok (Vword w) - -> write_lval (p_globs p) lv (Vword (zero_extend ws w)) s0' = ok s1 + -> sem_pexpr true (p_globs p) s0 e = ok (Vword w) + -> write_lval true (p_globs p) lv (Vword (zero_extend ws w)) s0' = ok s1 -> sem_i p' ev s0' (Copn [:: lv ] tag (Oarm aop) es) s1. Proof. move=> h hs00 hws hfv hseme hwrite. @@ -1232,9 +1234,9 @@ Qed. Lemma lower_cassgn_wordP ii s0 lv tag ws e v v' s0' s1' pre lvs op es : lower_cassgn_word fv lv ws e = Some (pre, (lvs, op, es)) - -> sem_pexpr (p_globs p) s0 e = ok v + -> sem_pexpr true (p_globs p) s0 e = ok v -> truncate_val (sword ws) v = ok v' - -> write_lval (p_globs p) lv v' s0' = ok s1' + -> write_lval true (p_globs p) lv v' s0' = ok s1' -> eq_fv s0' s0 -> disj_fvars (read_e e) -> disj_fvars (vars_lval lv) @@ -1273,9 +1275,9 @@ Qed. Lemma lower_cassgn_boolP ii s0 lv tag e v v' s0' s1' irs : lower_cassgn_bool fv lv tag e = Some irs - -> sem_pexpr (p_globs p) s0 e = ok v + -> sem_pexpr true (p_globs p) s0 e = ok v -> truncate_val sbool v = ok v' - -> write_lval (p_globs p) lv v' s0' = ok s1' + -> write_lval true (p_globs p) lv v' s0' = ok s1' -> eq_fv s0' s0 -> disj_fvars (read_e e) -> disj_fvars (vars_lval lv) @@ -1442,8 +1444,8 @@ Ltac rewrite_exec := Lemma with_shift_unop s eb ea ts (b: word ts) (a: u8) x vs sh opts r : (U32 ≤ ts)%CMP -> has_shift opts = None -> - sem_pexpr (p_globs p) s eb = ok (Vword b) -> - sem_pexpr (p_globs p) s ea = ok (Vword a) -> + sem_pexpr true (p_globs p) s eb = ok (Vword b) -> + sem_pexpr true (p_globs p) s ea = ok (Vword a) -> to_word reg_size x = ok (shift_op sh (zero_extend reg_size b) (wunsigned a)) -> exec_sopn (Oasm (BaseOp (None, ARM_op MVN opts))) [:: x & vs] = ok r -> exec_sopn (Oasm (BaseOp (None, ARM_op MVN (with_shift opts sh) ))) [:: Vword b, Vword a & vs] = ok r. @@ -1461,8 +1463,8 @@ Lemma with_shift_binop mn s eb ea ts (b: word ts) (a: u8) x y vs sh opts r : mn \in [:: ADD; SUB; RSB; AND; BIC; EOR; ORR; CMP; TST] -> (U32 ≤ ts)%CMP -> has_shift opts = None -> - sem_pexpr (p_globs p) s eb = ok (Vword b) -> - sem_pexpr (p_globs p) s ea = ok (Vword a) -> + sem_pexpr true (p_globs p) s eb = ok (Vword b) -> + sem_pexpr true (p_globs p) s ea = ok (Vword a) -> to_word reg_size y = ok (shift_op sh (zero_extend reg_size b) (wunsigned a)) -> exec_sopn (Oasm (BaseOp (None, ARM_op mn opts))) [:: x, y & vs] = ok r -> exec_sopn (Oasm (BaseOp (None, ARM_op mn (with_shift opts sh) ))) [:: x, Vword b, Vword a & vs] = ok r. @@ -1481,8 +1483,8 @@ Qed. Lemma with_shift_terop s eb ea ts (b: word ts) (a: u8) x y z vs sh opts r : (U32 ≤ ts)%CMP -> has_shift opts = None -> - sem_pexpr (p_globs p) s eb = ok (Vword b) -> - sem_pexpr (p_globs p) s ea = ok (Vword a) -> + sem_pexpr true (p_globs p) s eb = ok (Vword b) -> + sem_pexpr true (p_globs p) s ea = ok (Vword a) -> to_word reg_size y = ok (shift_op sh (zero_extend reg_size b) (wunsigned a)) -> exec_sopn (Oasm (BaseOp (None, ARM_op ADC opts))) [:: x, y, z & vs] = ok r -> exec_sopn (Oasm (BaseOp (None, ARM_op ADC (with_shift opts sh) ))) [:: x, Vword b, z, Vword a & vs] = ok r. @@ -1887,7 +1889,7 @@ Proof. move=> s0 s1 s2 s3 i v vs c hwrite hsem hc hsemf hfor. move=> hfv s0' hs00. - have {hwrite} hwrite : write_lval (p_globs p) i v s0 = ok s1. + have {hwrite} hwrite : write_lval true (p_globs p) i v s0 = ok s1. - exact: hwrite. have [hfvi hfvc] := disj_fvars_Cfor_c hfv. @@ -1949,8 +1951,8 @@ Proof. - exact: hinit. - exact: hwrite. - exact: hsem12'. - - rewrite -(sem_pexprs_get_var (p_globs p)). - rewrite -(sem_pexprs_get_var (p_globs p)) in hres. + - rewrite -(sem_pexprs_get_var _ (p_globs p)). + rewrite -(sem_pexprs_get_var _ (p_globs p)) in hres. exact: (eeq_exc_sem_pexprs (disj_fvars_vars_l_read_es hfvres) hs22 hres). - exact: htruncres. - move: hs22 => [-> _ _]. done. diff --git a/proofs/compiler/arm_params_proof.v b/proofs/compiler/arm_params_proof.v index 067dbf018..05021343c 100644 --- a/proofs/compiler/arm_params_proof.v +++ b/proofs/compiler/arm_params_proof.v @@ -41,22 +41,6 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. - -Lemma vmap_eq_except_wf_vm vm vm' x v : - wf_vm vm - -> vm' = vm [\ Sv.singleton x ] - -> get_var vm' x = ok v - -> wf_vm vm'. -Proof. - move=> hwf_vm hvm' hgetx. - move=> y. - case: (x =P y) => hy. - - subst y. move: hgetx. rewrite /get_var. by case: vm'.[x]%vmap => [|[]]. - rewrite hvm'; first by apply: hwf_vm. - exact: (Sv_neq_not_in_singleton hy). -Qed. - - Section Section. Context @@ -67,12 +51,13 @@ Context (* ------------------------------------------------------------------------ *) (* Flag combination hypotheses. *) +#[local] Existing Instance withsubword. -Lemma arm_cf_xsemP gd s e0 e1 e2 e3 cf v : +Lemma arm_cf_xsemP wdb gd s e0 e1 e2 e3 cf v : let: e := PappN (Ocombine_flags cf) [:: e0; e1; e2; e3 ] in let: e' := cf_xsem enot eand eor expr.eeq e0 e1 e2 e3 cf in - sem_pexpr gd s e = ok v - -> sem_pexpr gd s e' = ok v. + sem_pexpr wdb gd s e = ok v + -> sem_pexpr wdb gd s e' = ok v. Proof. rewrite /=. @@ -93,7 +78,7 @@ Proof. all: by rewrite ?hv0 ?hv1 ?hv2 ?hv3. Qed. -Definition arm_hpiparams : h_propagate_inline_params := +Definition arm_hpiparams {dc : DirectCall} : h_propagate_inline_params := {| pip_cf_xsemP := arm_cf_xsemP; |}. @@ -109,11 +94,11 @@ Context End STACK_ALLOC. -Lemma arm_mov_ofsP (P': sprog) s1 e i x tag ofs w vpk s2 ins : +Lemma arm_mov_ofsP {dc : DirectCall} (P': sprog) s1 e i x tag ofs w vpk s2 ins : p_globs P' = [::] - -> (Let i' := sem_pexpr [::] s1 e in to_pointer i') = ok i + -> (Let i' := sem_pexpr true [::] s1 e in to_pointer i') = ok i -> sap_mov_ofs arm_saparams x tag vpk e ofs = Some ins - -> write_lval [::] x (Vword (i + wrepr Uptr ofs)) s1 = ok s2 + -> write_lval true [::] x (Vword (i + wrepr Uptr ofs)) s1 = ok s2 -> psem.sem_i (pT := progStack) P' w s1 ins s2. Proof. rewrite /sap_mov_ofs /= /arm_mov_ofs => P'_globs. @@ -123,23 +108,22 @@ Proof. all: by rewrite /sem_sopn /= P'_globs /exec_sopn /sem_sop2 /= ok_z /= ok_i /= truncate_word_u /= ?truncate_word_u /= hx. Qed. -Lemma arm_immediateP (P': sprog) w s (x: var_i) z : +Lemma arm_immediateP {dc : DirectCall} (P': sprog) w s (x: var_i) z : vtype x = sword Uptr - -> psem.sem_i (pT := progStack) P' w s (arm_immediate x z) (with_vm s (evm s).[x <- pof_val x.(vtype) (Vword (wrepr Uptr z))])%vmap. + -> psem.sem_i (pT := progStack) P' w s (arm_immediate x z) (with_vm s (evm s).[x <- Vword (wrepr Uptr z)]). Proof. case: x => - [] [] // [] // x xi _ /=. constructor. by rewrite /sem_sopn /= /exec_sopn /= truncate_word_u. Qed. -Definition arm_hsaparams : - h_stack_alloc_params (ap_sap arm_params) := +Definition arm_hsaparams {dc : DirectCall} : + h_stack_alloc_params (ap_sap arm_params) := {| mov_ofsP := arm_mov_ofsP; sap_immediateP := arm_immediateP; |}. - (* ------------------------------------------------------------------------ *) (* Linearization hypotheses. *) @@ -178,27 +162,28 @@ Notation x := [pword_of_word]. 4. Rewrite result hypotheses, i.e. [write_lval]. *) + Ltac t_arm_op := rewrite /eval_instr /= /sem_sopn /= /exec_sopn /get_gvar /=; t_simpl_rewrites; rewrite /of_estate /= /with_vm /=; repeat rewrite truncate_word_u /=; - rewrite ?zero_extend_u ?pword_of_wordE addn1; + rewrite ?zero_extend_u addn1; t_simpl_rewrites. Lemma arm_op_subi_eval_instr lp ls ii y imm wy : - get_var (lvm ls) (v_var y) = ok (Vword wy) + get_var true (lvm ls) (v_var y) = ok (Vword wy) -> let: li := li_of_copn_args ii (arm_op_subi x y imm) in - let: wx' := (wy - wrepr reg_size imm)%R in - let: vm' := (lvm ls).[v_var x <- ok (pword_of_word wx')]%vmap in + let: wx' := Vword (wy - wrepr reg_size imm)in + let: vm' := (lvm ls).[v_var x <- wx'] in eval_instr lp li ls = ok (next_vm_ls ls vm'). Proof. move=> hgety. t_arm_op. by rewrite wsub_wnot1. Qed. -Lemma arm_op_align_eval_instr lp ls ii y al wy : - get_var (lvm ls) (v_var y) = ok (Vword wy) +Lemma arm_op_align_eval_instr lp ls ii y al (wy:word Uptr) : + get_var true (lvm ls) (v_var y) = ok (Vword wy) -> let: li := li_of_copn_args ii (arm_op_align x y al) in - let: wx' := align_word al wy in - let: vm' := (lvm ls).[v_var x <- ok (pword_of_word wx')]%vmap in + let: wx' := Vword (align_word al wy) in + let: vm' := (lvm ls).[v_var x <- wx'] in eval_instr lp li ls = ok (next_vm_ls ls vm'). Proof. move=> hgety. @@ -208,16 +193,16 @@ Proof. by rewrite wrepr_wnot ZlnotE Z.sub_1_r Z.add_1_r Z.succ_pred. Qed. -Lemma arm_op_mov_eval_instr lp ls ii y wy : - get_var (lvm ls) (v_var y) = ok (Vword wy) +Lemma arm_op_mov_eval_instr lp ls ii y (wy: word Uptr) : + get_var true (lvm ls) (v_var y) = ok (Vword wy) -> let: li := li_of_copn_args ii (arm_op_mov x y) in - let: vm' := (lvm ls).[v_var x <- ok (pword_of_word wy)]%vmap in + let: vm' := (lvm ls).[v_var x <- Vword wy] in eval_instr lp li ls = ok (next_vm_ls ls vm'). Proof. move=> hgety. by t_arm_op. Qed. Lemma arm_op_str_off_eval_instr lp ls m' ii y off wx (wy : word reg_size) : - get_var (lvm ls) (v_var x) = ok (Vword wx) - -> get_var (lvm ls) (v_var y) = ok (Vword wy) + get_var true (lvm ls) (v_var x) = ok (Vword wx) + -> get_var true (lvm ls) (v_var y) = ok (Vword wy) -> write (lmem ls) (wx + wrepr Uptr off)%R wy = ok m' -> let: li := li_of_copn_args ii (arm_op_str_off y x off) in eval_instr lp li ls = ok (next_mem_ls ls m'). @@ -378,8 +363,8 @@ Lemma arm_cmd_load_large_imm_lsem lp fn s ii P Q xname imm : |} in [/\ lsem lp ls ls' - , vm' = lvm ls [\ Sv.singleton x ] - & get_var vm' x = ok (Vword (wrepr reg_size imm)) + , vm' =[\ Sv.singleton x ] lvm ls + & get_var true vm' x = ok (Vword (wrepr reg_size imm)) ]. Proof. set x := {| v_var := _; |}. @@ -394,18 +379,17 @@ Proof. + rewrite -(addn0 (size P)). rewrite (find_instr_skip hbody) /=. rewrite /eval_instr /= /with_vm /= /of_estate /=. - rewrite /exec_sopn /= truncate_word_u /= pword_of_wordE addn0. + rewrite /exec_sopn /= truncate_word_u /= addn0. reflexivity. rewrite -addn1. rewrite (find_instr_skip hbody) /=. rewrite /eval_instr /=. rewrite /sem_sopn /= /get_gvar /=. - rewrite get_var_eq /=. + rewrite get_var_eq //=. rewrite /with_vm /= /of_estate /=. rewrite /exec_sopn /= !truncate_word_u /=. rewrite (mov_movt himm hdivmod). - rewrite pword_of_wordE. rewrite addn1 -addn2. reflexivity. @@ -420,7 +404,7 @@ Lemma arm_cmd_large_subi_lsem lp fn s ii P Q xname y imm wy : let: lcmd := map (li_of_copn_args ii) (arm_cmd_large_subi xi y imm) in is_linear_of lp fn (P ++ lcmd ++ Q) -> x <> v_var y - -> get_var (evm s) (v_var y) = ok (Vword wy) + -> get_var true (evm s) (v_var y) = ok (Vword wy) -> (0 <= imm < wbase reg_size)%Z -> exists vm', let: ls := of_estate s fn (size P) in @@ -434,8 +418,8 @@ Lemma arm_cmd_large_subi_lsem lp fn s ii P Q xname y imm wy : |} in [/\ lsem lp ls ls' - , vm' = evm s [\ Sv.singleton x ] - & get_var vm' x = ok (Vword (wy - wrepr reg_size imm)%R) + , vm' =[\ Sv.singleton x ] evm s + & get_var true vm' x = ok (Vword (wy - wrepr reg_size imm)%R) ]. Proof. set x := {| v_var := _; |}. @@ -463,22 +447,22 @@ Proof. rewrite (find_instr_skip hbody) /=. have {hgety} hgety : - get_var vm' y = ok (Vword wy). - + rewrite (get_var_eq_except _ hvm) /=; first exact: hgety. + get_var true vm' y = ok (Vword wy). + + rewrite (get_var_eq_ex _ _ hvm) /=; first exact: hgety. exact: (Sv_neq_not_in_singleton hxy). rewrite /eval_instr /=. rewrite /sem_sopn /=. rewrite /get_gvar /=. rewrite hgetx hgety {hgetx hgety} /=. - rewrite /exec_sopn /= !truncate_word_u /= pword_of_wordE. + rewrite /exec_sopn /= !truncate_word_u /=. rewrite /of_estate /with_vm /=. rewrite wsub_wnot1. rewrite !size_cat addn0 -addn1 addnA /=. reflexivity. - move=> z hz. - rewrite Fv.setP_neq. + rewrite Vm.setP_neq. + rewrite -(hvm z hz) /=; first done. apply/eqP. SvD.fsetdec. @@ -499,36 +483,36 @@ Let vtmpi : var_i := VarI vtmp dummy_var_info. Lemma arm_spec_lip_allocate_stack_frame s pc ii ts sz : let args := lip_allocate_stack_frame arm_liparams vrspi sz in let i := MkLI ii (Lopn args.1.1 args.1.2 args.2) in - let ts' := pword_of_word (ts - wrepr Uptr sz) in - let s' := with_vm s (evm s).[vrsp <- ok ts']%vmap in - (evm s).[vrsp]%vmap = ok (pword_of_word ts) + let ts' := Vword (ts - wrepr Uptr sz) in + let s' := with_vm s (evm s).[vrsp <- ts'] in + (evm s).[vrsp] = Vword ts -> eval_instr lp i (of_estate s fn pc) = ok (of_estate s' fn pc.+1). Proof. move=> /= hvm. rewrite /eval_instr /=. rewrite /sem_sopn /=. - rewrite /get_gvar /get_var /on_vu /=. + rewrite /get_gvar /get_var /=. rewrite hvm /=. - rewrite /exec_sopn /= !truncate_word_u /= pword_of_wordE. + rewrite /exec_sopn /= !truncate_word_u /=. by rewrite wsub_wnot1. Qed. Lemma arm_spec_lip_free_stack_frame s pc ii ts sz : let args := lip_free_stack_frame arm_liparams vrspi sz in let i := MkLI ii (Lopn args.1.1 args.1.2 args.2) in - let ts' := pword_of_word (ts + wrepr Uptr sz) in - let s' := with_vm s (evm s).[vrsp <- ok ts']%vmap in - (evm s).[vrsp]%vmap = ok (pword_of_word ts) + let ts' := Vword (ts + wrepr Uptr sz) in + let s' := with_vm s (evm s).[vrsp <- ts'] in + (evm s).[vrsp] = Vword ts -> eval_instr lp i (of_estate s fn pc) = ok (of_estate s' fn pc.+1). Proof. move=> /= hvm. rewrite /eval_instr /=. rewrite /sem_sopn /=. - rewrite /get_gvar /get_var /on_vu /=. + rewrite /get_gvar /get_var /=. rewrite hvm /=. - by rewrite /exec_sopn /= !truncate_word_u /= pword_of_wordE. + by rewrite /exec_sopn /= !truncate_word_u /=. Qed. Lemma arm_spec_lip_set_up_sp_register s r ts al sz P Q : @@ -540,22 +524,20 @@ Lemma arm_spec_lip_set_up_sp_register s r ts al sz P Q : -> vtmp <> vrsp -> vname (v_var r) \notin (lip_not_saved_stack arm_liparams) -> v_var r <> vrsp - -> get_var (evm s) vrspi = ok (Vword ts) - -> wf_vm (evm s) + -> get_var true (evm s) vrspi = ok (Vword ts) -> exists vm', let: ls := of_estate s fn (size P) in let: s' := with_vm s vm' in let: ls' := of_estate s' fn (size P + size lcmd) in let: vars := Sv.add (v_var r) (Sv.add vtmp (Sv.add vrsp vflags)) in [/\ lsem lp ls ls' - , wf_vm vm' - , vm' = (evm s) [\ vars ] - , get_var vm' vrspi = ok (Vword ts') - , get_var vm' r = ok (Vword ts) + , vm' =[\ vars ] (evm s) + , get_var true vm' vrspi = ok (Vword ts') + , get_var true vm' r = ok (Vword ts) & forall x, Sv.In x vflags - -> ~ is_ok (vm'.[x]%vmap) - -> (evm s).[x]%vmap = vm'.[x]%vmap + -> ~ is_defined vm'.[x] + -> (evm s).[x] = vm'.[x] ]. Proof. set ts' := align_word _ _. @@ -563,7 +545,7 @@ Proof. set r := {| v_info := rinfo; |}. move=> - hbody hset_up ? hneq_tmp_rsp hnot_saved_stack hneq_r_rsp hgetrsp hwf_vm; + hbody hset_up ? hneq_tmp_rsp hnot_saved_stack hneq_r_rsp hgetrsp; subst rtype. move: hset_up. @@ -588,14 +570,14 @@ Proof. move=> hbody. (* We need [vm1] before [eexists]. *) - set vm0 := (evm s).[v_var r <- ok (pword_of_word ts)]%vmap. + set vm0 := (evm s).[v_var r <- Vword ts]. have hsz : (0 <= sz < wbase reg_size)%Z. - by move: hset_up => /andP [] /ZleP hlo /ZltP hhi. clear hset_up. have hgetrsp0 : - get_var vm0 vrsp = ok (Vword ts). + get_var true vm0 vrsp = ok (Vword ts). + rewrite get_var_neq; first exact: hgetrsp. exact: hneq_r_rsp. @@ -607,8 +589,8 @@ Proof. hgetrsp0 hsz. - set vm2 := vm1.[vtmp <- ok (pword_of_word ts')]%vmap. - set vm3 := vm2.[vrsp <- ok (pword_of_word ts')]%vmap. + set vm2 := vm1.[vtmp <- Vword ts']. + set vm3 := vm2.[vrsp <- Vword ts']. exists vm3; split. @@ -662,7 +644,7 @@ Proof. rewrite onth_cat lt_nm_n sub_nmn /=. have hgettmp2 : - get_var vm2 vtmp = ok (Vword ts'). + get_var true vm2 vtmp = ok (Vword ts'). * by rewrite get_var_eq. rewrite !size_cat /=. @@ -680,10 +662,6 @@ Proof. (y := vtmpi) hgettmp2). - - repeat apply: wf_vm_set. - apply: (vmap_eq_except_wf_vm _ hvm1 hgettmp1). - exact: (wf_vm_set _ hwf_vm). - - move=> x. t_notin_add. t_vm_get. @@ -694,7 +672,7 @@ Proof. - by t_get_var. - t_get_var. - rewrite (get_var_eq_except _ hvm1); first by t_get_var. + rewrite (get_var_eq_ex _ _ hvm1); first by t_get_var. apply: Sv_neq_not_in_singleton. by apply/nesym. @@ -722,8 +700,7 @@ Lemma arm_spec_lip_set_up_sp_stack s ts m' al sz off P Q : is_linear_of lp fn (P ++ lcmd ++ Q) -> isSome (lip_set_up_sp_stack arm_liparams vrspi sz al off) -> vtmp <> vrsp - -> get_var (evm s) vrspi = ok (Vword ts) - -> wf_vm (evm s) + -> get_var true (evm s) vrspi = ok (Vword ts) -> write (emem s) (ts' + wrepr Uptr off)%R ts = ok m' -> exists vm', let: ls := of_estate s fn (size P) in @@ -731,17 +708,16 @@ Lemma arm_spec_lip_set_up_sp_stack s ts m' al sz off P Q : let: ls' := of_estate s' fn (size P + size lcmd) in let: vars := Sv.add vtmpi (Sv.add vrspi vflags) in [/\ lsem lp ls ls' - , wf_vm vm' - , vm' = (evm s) [\ vars ] - , get_var vm' vrspi = ok (Vword ts') + , vm' =[\ vars ] (evm s) + , get_var true vm' vrspi = ok (Vword ts') & forall x, Sv.In x vflags - -> ~ is_ok (vm'.[x]%vmap) - -> (evm s).[x]%vmap = vm'.[x]%vmap + -> ~ is_defined vm'.[x] + -> (evm s).[x] = vm'.[x] ]. Proof. set ts' := align_word _ _. - move=> hbody hset_up hneq_tmp_rsp hgetrsp hwf_vm hwrite. + move=> hbody hset_up hneq_tmp_rsp hgetrsp hwrite. move: hset_up. rewrite /= /arm_set_up_sp_stack. @@ -765,17 +741,17 @@ Proof. have [vm0 [hsem hvm0 hgettmp0]] := arm_cmd_large_subi_lsem (s := s) hbody hneq_tmp_rsp hgetrsp hsz. - set vm1 := vm0.[vtmp <- ok (pword_of_word ts')]%vmap. - set vm2 := vm1.[vrsp <- ok (pword_of_word ts')]%vmap. + set vm1 := vm0.[vtmp <- Vword ts']. + set vm2 := vm1.[vrsp <- Vword ts']. have hgetrsp1 : - get_var vm1 vrsp = ok (Vword ts). + get_var true vm1 vrsp = ok (Vword ts). * rewrite get_var_neq; last exact: hneq_tmp_rsp. - rewrite (get_var_eq_except _ hvm0); first exact: hgetrsp. + rewrite (get_var_eq_ex _ _ hvm0); first exact: hgetrsp. exact: (Sv_neq_not_in_singleton hneq_tmp_rsp). have hgettmp1 : - get_var vm1 vtmp = ok (Vword ts'). + get_var true vm1 vtmp = ok (Vword ts'). * by rewrite get_var_eq. eexists. @@ -826,9 +802,6 @@ Proof. (y := vtmpi) hgettmp1). - - repeat apply: wf_vm_set. - exact: (vmap_eq_except_wf_vm hwf_vm hvm0 hgettmp0). - - move=> x. t_notin_add. t_vm_get. @@ -945,6 +918,7 @@ Qed. (* Lowering hypotheses. *) Lemma arm_lower_callP + { dc : DirectCall } (eft : eqType) (pT : progT eft) (sCP : semCallParams) @@ -971,12 +945,11 @@ Proof. exact: lower_callP. Qed. -Definition arm_hloparams : h_lowering_params (ap_lop arm_params) := +Definition arm_hloparams { dc : DirectCall } : h_lowering_params (ap_lop arm_params) := {| hlop_lower_callP := arm_lower_callP; |}. - (* ------------------------------------------------------------------------ *) (* Assembly generation hypotheses. *) @@ -1068,7 +1041,7 @@ Qed. Lemma eval_assemble_cond_Pvar ii m rf x r v : eqflags m rf -> of_var_e ii x = ok r - -> get_var (evm m) x = ok v + -> get_var true (evm m) x = ok v -> exists2 v', value_of_bool (eval_cond (get_rf rf) (condt_of_rflag r)) = ok v' & value_uincl v v'. @@ -1107,9 +1080,9 @@ Lemma eval_assemble_cond_Obeq ii m rf v x0 x1 r0 r1 v0 v1 : is_rflags_GE r0 r1 = true -> eqflags m rf -> of_var_e ii x0 = ok r0 - -> get_var (evm m) x0 = ok v0 + -> get_var true (evm m) x0 = ok v0 -> of_var_e ii x1 = ok r1 - -> get_var (evm m) x1 = ok v1 + -> get_var true (evm m) x1 = ok v1 -> sem_sop2 Obeq v0 v1 = ok v -> exists2 v', value_of_bool (eval_cond (get_rf rf) GE_ct) = ok v' & value_uincl v v'. @@ -1238,7 +1211,7 @@ Qed. (* TODO_ARM: Is there a way of avoiding importing here? *) Import arch_sem. -Lemma arm_assemble_extra_op rip ii op lvs args m xs ys m' s ops ops': +Lemma arm_assemble_extra_op rip ii op lvs args m xs ys m' s ops ops' : sem_rexprs m args = ok xs -> exec_sopn (Oasm (ExtOp op)) xs = ok ys -> write_lexprs lvs ys m = ok m' @@ -1286,7 +1259,7 @@ Proof. by constructor; move=> ???? []. Qed. (* ------------------------------------------------------------------------ *) -Definition arm_h_params : h_architecture_params arm_params := +Definition arm_h_params {dc : DirectCall} : h_architecture_params arm_params := {| hap_hpip := arm_hpiparams; hap_hsap := arm_hsaparams; diff --git a/proofs/compiler/array_copy_proof.v b/proofs/compiler/array_copy_proof.v index a3b67837b..db563e2dc 100644 --- a/proofs/compiler/array_copy_proof.v +++ b/proofs/compiler/array_copy_proof.v @@ -9,21 +9,21 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope vmap. Local Open Scope seq_scope. Local Open Scope Z_scope. Section WITH_PARAMS. Context + {wsw : WithSubWord} + {dc:DirectCall} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} {sip : SemInstrParams asm_op syscall_state} {T : eqType} {pT : progT T} - {sCP : semCallParams} - (wf_init : wf_init sCP). + {sCP : semCallParams}. Context (fresh_counter: Ident.ident) (p1 p2: prog) (ev: extra_val_t). @@ -100,10 +100,10 @@ Proof. move=> ii i s1 s2 _; apply. Qed. Local Lemma Hassgn : sem_Ind_assgn p1 Pi_r. Proof. move=> s1 s2 x tag ty e v v' he htr hw ii; rewrite /Pi vars_I_assgn /vars_lval => hsub /= _ [<-] vm1 hvm1. - have [|v1 hv1 uv1]:= sem_pexpr_uincl_on (vm2:= vm1) _ he; first by apply: vmap_uincl_onI hvm1;SvD.fsetdec. + have [|v1 hv1 uv1]:= sem_pexpr_uincl_on (vm2:= vm1) _ he; first by apply: uincl_onI hvm1;SvD.fsetdec. have [v1' hv1' uv1']:= value_uincl_truncate uv1 htr. have [|vm2 hvm2 hw']:= write_lval_uincl_on _ uv1' hw hvm1; first by SvD.fsetdec. - exists vm2 => //=; first by apply: vmap_uincl_onI hvm2; SvD.fsetdec. + exists vm2 => //=; first by apply: uincl_onI hvm2; SvD.fsetdec. apply sem_seq1; constructor; econstructor; eauto; rewrite -eq_globs //. Qed. @@ -123,10 +123,10 @@ Proof. rewrite /Pi vars_I_opn /vars_lvals => hsub /=. case: is_copy (@is_copyP o); last first. + move=> _ _ [<-] vm1 hvm1. - have [|ves' hves' uves]:= sem_pexprs_uincl_on (vmap_uincl_onI _ hvm1) hves; first by SvD.fsetdec. + have [|ves' hves' uves]:= sem_pexprs_uincl_on (uincl_onI _ hvm1) hves; first by SvD.fsetdec. have [ vs' ho' vs_vs' ] := vuincl_exec_opn uves ho. have [| vm2 hvm2 hw']:= write_lvals_uincl_on _ vs_vs' hw hvm1; first by SvD.fsetdec. - exists vm2; first by apply: vmap_uincl_onI hvm2; SvD.fsetdec. + exists vm2; first by apply: uincl_onI hvm2; SvD.fsetdec. apply sem_seq1; constructor; econstructor; eauto. by rewrite /sem_sopn -eq_globs hves' /= ho' /=. move=> [ws n] /(_ _ _ refl_equal) ?; subst o. @@ -143,35 +143,36 @@ Proof. move: ho; rewrite /exec_sopn /=; t_xrbindP => tx ty hty. rewrite /sopn_sem /= => hcopy ?; subst vs; t_xrbindP => s hw ?; subst s. have [|v1 hv1 /value_uinclE uv1] := sem_pexpr_uincl_on (vm2:= vm1) (e:= Pvar y) _ hy. - + by apply: vmap_uincl_onI hvm1;SvD.fsetdec. + + by apply: uincl_onI hvm1;SvD.fsetdec. have ? := to_arrI hty; subst vy. case: uv1 => [ty1 ? ut]; subst v1. set ipre := if _ then _ else _; set c := [:: MkI _ (Cassgn _ _ _ _) ]. have [vm1' [hvm1' [tx0 htx0]] hipre] : exists2 vm1', - vm1 <=[Sv.union (read_e y) (Sv.remove x X)] vm1' /\ exists tx, vm1'.[x] = ok tx & + vm1 <=[Sv.union (read_e y) (Sv.remove x X)] vm1' /\ exists tx, vm1'.[x] = @Varr len tx & sem_I p2 ev (with_vm s1 vm1) (MkI ii ipre) (with_vm s1 vm1'). + rewrite /ipre; case: ifPn => hxy. + exists vm1; last by constructor; econstructor. split => //. case/andP: hxy => /= /eqP hl /eqP /= heq; subst vx. - move: hv1; rewrite /= /get_gvar /is_lvar hl eqxx /get_var. - by apply: on_vuP; rewrite -heq //= => t0 h _; exists t0. - exists (vm1.[x <- ok (WArray.empty len)]). - + split; last by exists (WArray.empty len); rewrite Fv.setP_eq. - move=> z hz; rewrite Fv.setP_neq //; apply /eqP => heq; subst z. + move: hv1; rewrite /= /get_gvar /is_lvar hl eqxx /get_var; t_xrbindP => _. + rewrite -heq; eauto. + exists (vm1.[x <- Varr (WArray.empty len)]). + + split; last by rewrite Vm.setP_eq /= eqxx; eauto. + move=> z hz; rewrite Vm.setP_neq //; apply /eqP => heq; subst z. have : Sv.In x (read_e y) by SvD.fsetdec. by move: hxy; rewrite read_e_var /eq_gvar /= /read_gvar; case: (y) => /= vy [/= /eqP | /=]; SvD.fsetdec. constructor; apply: Eassgn => //=; first by rewrite /truncate_val /= WArray.castK. - by rewrite /write_var /set_var /= /on_vu WArray.castK. + by rewrite write_var_eq_type. move: hcopy; rewrite /WArray.copy -/len => /(WArray.fcopy_uincl (WArray.uincl_empty tx0 erefl)) => -[tx'] hcopy hutx. have : forall (j:Z), 0 <= j -> j <= n -> - forall vm1' (tx0:WArray.array len), + forall vm1' (tx0:WArray.array len), vm1 <=[Sv.union (read_e y) (Sv.remove x X)] vm1' -> - vm1'.[x] = ok tx0 -> WArray.fcopy ws ty tx0 (Zpos n - j) j = ok tx' -> + vm1'.[x] = Varr tx0 -> + WArray.fcopy ws ty tx0 (Zpos n - j) j = ok tx' -> exists2 vm2, - (vm1 <=[Sv.union (read_e y) (Sv.remove x X)] vm2 /\ vm2.[x] = ok tx') & + (vm1 <=[Sv.union (read_e y) (Sv.remove x X)] vm2 /\ vm2.[x] = Varr tx') & sem_for p2 ev i (ziota (Zpos n - j) j) (with_vm s1 vm1') c (with_vm s1 vm2). + move=> {hy vm1' hvm1' htx0 hipre hcopy hutx tx0 tx hw}. apply: natlike_ind => [ | j hj hrec] hjn vm1' tx hvm1' hx. @@ -179,52 +180,48 @@ Proof. Opaque Z.sub. rewrite /WArray.fcopy ziotaS_cons //=; have -> : n - Z.succ j + 1 = n - j by ring. t_xrbindP => tx1 w hget hset hcopy. - have [] := hrec _ (vm1'.[i <- ok (n - Z.succ j)].[x <- ok tx1]) tx1 => //. + have [] := hrec _ (vm1'.[i <- Vint (n - Z.succ j)].[x <- Varr tx1]) tx1 => //. + by Psatz.lia. + rewrite read_e_var; move=> z hz. case: (v_var x =P z) => hxz. - + subst z; rewrite Fv.setP_eq. + + subst z; rewrite Vm.setP_eq. have [hxy hyl]: v_var (gv y) = v_var x /\ is_lvar y. + by move: hz; rewrite /read_gvar; case: ifP => ?; first split => //; SvD.fsetdec. - move: hv1; rewrite /= /get_gvar hyl /get_gvar hxy /get_var; apply on_vuP => //=. - move=> _t heq /Varr_inj [en]; rewrite (Eqdep_dec.UIP_dec Pos.eq_dec en erefl) /= => ?. - subst. - rewrite heq /= /pval_uincl /value_uincl /=. - split; first by Psatz.lia. - move: hvm1'; rewrite read_e_var => /(_ _ hz) /=; rewrite hx heq /= /pval_uincl /= => hu k w8. + move: hv1; rewrite /= /get_gvar hyl /get_gvar hxy /get_var; t_xrbindP => _ heq. + rewrite heq /len eqxx; split => //. + move: hvm1'; rewrite read_e_var => /(_ _ hz) /=; rewrite hx heq /= => hu k w8. case: (hu) => _ h /h hw8; rewrite (write_read8 hset) /=. rewrite WArray.subE; case: andP => //; rewrite !zify => hb. have [_ htxy] := WArray.uincl_trans ut hu. have [ _ /(_ _ hb) -/htxy <-] := read_read8 hget. by rewrite -hw8 WArray.addE /mk_scale; f_equal; ring. - rewrite Fv.setP_neq; last by apply /eqP. - rewrite Fv.setP_neq; first by apply: hvm1'; rewrite read_e_var. + rewrite Vm.setP_neq; last by apply /eqP. + rewrite Vm.setP_neq; first by apply: hvm1'; rewrite read_e_var. by apply /eqP; move: viX hsub hz; rewrite /vi read_e_var /=; SvD.fsetdec. - + by rewrite Fv.setP_eq. + + by rewrite Vm.setP_eq /= eqxx. move=> vm2 h1 h2; exists vm2 => //. - apply: (EForOne (s1' := with_vm s1 vm1'.[i <- ok (n - Z.succ j)])) h2 => //. + apply: (EForOne (s1' := with_vm s1 vm1'.[i <- Vint (n - Z.succ j)])) h2. + + by rewrite write_var_eq_type. apply sem_seq1; constructor. apply: Eassgn. + rewrite /= get_gvar_neq; last first. - + by move=> _ heqy; move: hv1 => /= /type_of_get_gvar; rewrite -heqy. + + by move=> _ heqy; move: hv1 => /= /type_of_get_gvar /= /compat_typeEl; rewrite -heqy. case: (sem_pexpr_uincl_on (vm2 := vm1') _ hv1). - + by apply: vmap_uincl_onI hvm1'; SvD.fsetdec. + + by apply: uincl_onI hvm1'; SvD.fsetdec. move=> _v hv /value_uinclE [? ? hty']; subst _v. rewrite -eq_globs; move: hv => /= => -> /=. - by rewrite (@get_gvar_eq _ (mk_lvar i)) //= (WArray.uincl_get (WArray.uincl_trans ut hty') hget). + by rewrite (@get_gvar_eq _ _ _ (mk_lvar i)) //= (WArray.uincl_get (WArray.uincl_trans ut hty') hget). + by rewrite /truncate_val /= truncate_word_u. - rewrite /= get_var_neq //= /get_var hx /= (@get_gvar_eq _ (mk_lvar i)) //= truncate_word_u /=. - by rewrite hset /= /write_var /set_var /= WArray.castK. + rewrite /= get_var_neq //= /get_var hx /= (@get_gvar_eq _ _ _ (mk_lvar i)) //= truncate_word_u /=. + by rewrite hset /= write_var_eq_type. move=> /(_ n _ _ vm1' tx0 hvm1' htx0) [] => //;first by Psatz.lia. + by rewrite Z.sub_diag. rewrite Z.sub_diag => vm2 [] hvm2 htx' hfor; exists vm2. + move=> z hz; case: (v_var x =P z) => [<- | hne]. - + move: hw; rewrite htx'/write_var; t_xrbindP => vm. - rewrite /set_var; apply: on_vuP => //= t0 hc <- <- /=. - rewrite Fv.setP_eq /= /pval_uincl /=. - by apply: WArray.uincl_trans hutx; apply: WArray.cast_uincl hc. + + move: hw; rewrite htx' => /write_varP_arr [h ? ? ->]. + by rewrite Vm.setP_eq (vm_truncate_val_eq h). rewrite -(vrvP_var hw); last by SvD.fsetdec. - apply: eval_uincl_trans; first by apply hvm1. + apply: value_uincl_trans; first by apply hvm1. by apply hvm2; SvD.fsetdec. apply: (Eseq hipre); apply sem_seq1; constructor. apply: Efor => //. @@ -235,10 +232,10 @@ Qed. Local Lemma Hsyscall : sem_Ind_syscall p1 Pi_r. Proof. move=> s1 scs m s2 o xs es ves vs he hsys hw ii; rewrite /Pi vars_I_syscall /vars_lvals => hsub /= _ [<-] vm1 hvm1. - have [|v1 hv1 uv1]:= sem_pexprs_uincl_on (vm2:= vm1) _ he; first by apply: vmap_uincl_onI hvm1;SvD.fsetdec. + have [|v1 hv1 uv1]:= sem_pexprs_uincl_on (vm2:= vm1) _ he; first by apply: uincl_onI hvm1;SvD.fsetdec. have [vs' hsys' uv1'] := exec_syscallP hsys uv1. have [|vm2 hvm2 hw']:= write_lvals_uincl_on _ uv1' hw hvm1; first by SvD.fsetdec. - exists vm2 => //=; first by apply: vmap_uincl_onI hvm2; SvD.fsetdec. + exists vm2 => //=; first by apply: uincl_onI hvm2; SvD.fsetdec. by apply sem_seq1; constructor; econstructor; eauto; rewrite -eq_globs. Qed. @@ -246,7 +243,7 @@ Local Lemma Hif_true : sem_Ind_if_true p1 ev Pc Pi_r. Proof. move => s1 s2 e c1 c2 he _ hc ii; rewrite /Pi vars_I_if => hsub c /=. t_xrbindP => c1' hc1 c2' hc2 <- vm1 hvm1. - have [|v hv /value_uinclE ?]:= sem_pexpr_uincl_on (vmap_uincl_onI _ hvm1) he; first by SvD.fsetdec. + have [|v hv /value_uinclE ?]:= sem_pexpr_uincl_on (uincl_onI _ hvm1) he; first by SvD.fsetdec. subst v; have [| vm2 h1 h2] := hc _ _ hc1 vm1 hvm1; first by SvD.fsetdec. by exists vm2 => //=; apply sem_seq1; constructor; apply: Eif_true => //; rewrite -eq_globs. Qed. @@ -255,7 +252,7 @@ Local Lemma Hif_false : sem_Ind_if_false p1 ev Pc Pi_r. Proof. move => s1 s2 e c1 c2 he _ hc ii; rewrite /Pi vars_I_if => hsub c /=. t_xrbindP => c1' hc1 c2' hc2 <- vm1 hvm1. - have [|v hv /value_uinclE ?]:= sem_pexpr_uincl_on (vmap_uincl_onI _ hvm1) he; first by SvD.fsetdec. + have [|v hv /value_uinclE ?]:= sem_pexpr_uincl_on (uincl_onI _ hvm1) he; first by SvD.fsetdec. subst v; have [| vm2 h1 h2]:= hc _ _ hc2 vm1 hvm1; first by SvD.fsetdec. by exists vm2 => //=; apply sem_seq1; constructor; apply: Eif_false => //; rewrite -eq_globs. Qed. @@ -266,7 +263,7 @@ Proof. rewrite /Pi vars_I_while => hsub c2 /=. t_xrbindP => c1 hc1 c1' hc1' <- vm1 hvm1. have [|vm2 hvm2 hc_] := hc _ _ hc1 vm1 hvm1; first by SvD.fsetdec. - have [|v hv /value_uinclE ?]:= sem_pexpr_uincl_on (vmap_uincl_onI _ hvm2) he; first by SvD.fsetdec. + have [|v hv /value_uinclE ?]:= sem_pexpr_uincl_on (uincl_onI _ hvm2) he; first by SvD.fsetdec. subst v; have [|vm3 hvm3 hc'_] := hc' _ _ hc1' vm2 hvm2; first by SvD.fsetdec. have /= := hw ii _; rewrite hc1 hc1' /= => /(_ _ _ refl_equal vm3 hvm3). move=> [|vm4 hvm4 /= /sem_seq1_iff /sem_IE /= hw_]; first by rewrite vars_I_while. @@ -279,7 +276,7 @@ Proof. rewrite /Pi vars_I_while => hsub c2 /=. t_xrbindP => c1 hc1 c1' hc1' <- vm1 hvm1. have [|vm2 hvm2 hc_] := hc _ _ hc1 vm1 hvm1; first by SvD.fsetdec. - have [|v hv /value_uinclE ?]:= sem_pexpr_uincl_on (vmap_uincl_onI _ hvm2) he; first by SvD.fsetdec. + have [|v hv /value_uinclE ?]:= sem_pexpr_uincl_on (uincl_onI _ hvm2) he; first by SvD.fsetdec. subst v; exists vm2 => //=; apply sem_seq1; constructor; apply: Ewhile_false; rewrite -?eq_globs; eauto. Qed. @@ -288,8 +285,8 @@ Proof. move => s1 s2 i d lo hi c vlo vhi hlo hhi _ hfor ii. rewrite /Pi vars_I_for => hsub c2 /=. t_xrbindP => c' hc <- vm1 hvm1 /=. - have [|vlo' hlo' /value_uinclE ?]:= sem_pexpr_uincl_on (vmap_uincl_onI _ hvm1) hlo; first by SvD.fsetdec. - have [|vhi' hhi' /value_uinclE ?]:= sem_pexpr_uincl_on (vmap_uincl_onI _ hvm1) hhi; first by SvD.fsetdec. + have [|vlo' hlo' /value_uinclE ?]:= sem_pexpr_uincl_on (uincl_onI _ hvm1) hlo; first by SvD.fsetdec. + have [|vhi' hhi' /value_uinclE ?]:= sem_pexpr_uincl_on (uincl_onI _ hvm1) hhi; first by SvD.fsetdec. subst vlo' vhi'; have [|vm2 hvm2 hfor']:= hfor _ _ hc vm1 hvm1; first by SvD.fsetdec. exists vm2 => //; apply sem_seq1; constructor; econstructor; rewrite -?eq_globs; eauto. Qed. @@ -300,8 +297,8 @@ Proof. move=> s i c hsub ?? vm1 hvm1; exists vm1 => //; constructor. Qed. Local Lemma Hfor_cons : sem_Ind_for_cons p1 ev Pc Pfor. Proof. move=> s1 s1' s2 s3 i w ws c hi _ hc _ hfor hsub ? heq vm1 hvm1. - have [vm2 hvm2 hi']:= write_var_uincl_on' (value_uincl_refl w) hi hvm1. - have [||vm3 hvm3 hc']:= hc _ _ heq vm2 (vmap_uincl_onI _ hvm2). + have [vm2 hi' hvm2]:= write_var_uincl_on (value_uincl_refl w) hi hvm1. + have [||vm3 hvm3 hc']:= hc _ _ heq vm2 (uincl_onI _ hvm2). + by SvD.fsetdec. + by SvD.fsetdec. have [vm4 hvm4 hfor']:= hfor hsub _ heq _ hvm3. exists vm4 => //=; econstructor; eauto. @@ -311,10 +308,10 @@ Local Lemma Hcall : sem_Ind_call p1 ev Pi_r Pfun. Proof. move=> s1 scs2 m2 s2 ii xs fn args vargs vs he _ hfun hw ii'. rewrite /Pi vars_I_call /vars_lvals => hsub _ [<-] vm1 hvm1. - have [|vargs' he' uvars]:= sem_pexprs_uincl_on (vmap_uincl_onI _ hvm1) he; first by SvD.fsetdec. + have [|vargs' he' uvars]:= sem_pexprs_uincl_on (uincl_onI _ hvm1) he; first by SvD.fsetdec. have [vs' hfun' uvs']:= hfun _ uvars. have [| vm2 hvm2 hw']:= write_lvals_uincl_on _ uvs' hw hvm1; first by SvD.fsetdec. - exists vm2; first by apply: vmap_uincl_onI hvm2; SvD.fsetdec. + exists vm2; first by apply: uincl_onI hvm2; SvD.fsetdec. apply sem_seq1; constructor; econstructor; rewrite -?eq_globs; eauto. Qed. @@ -325,19 +322,19 @@ Proof. have [fd2 hfd hget']:= all_checked hget. have hpex : p_extra p1 = p_extra p2. + by move: Hp; rewrite /array_copy_prog; t_xrbindP => ??? <-. - have [vargs1' hca' uvargs'] := mapM2_truncate_val hca hva. + have [vargs1' hca' uvargs'] := mapM2_dc_truncate_val hca hva. have [vm2 hw' hvm2] := write_vars_uincl (vm_uincl_refl (evm s0)) uvargs' hw. have := vars_pP hget; rewrite /vars_fd -/X => /= hsub. move: hfd; rewrite /array_copy_fd; t_xrbindP => body' heq ?; subst fd2. have [||vm3 hvm3 hc'] := hc _ _ heq vm2. + by SvD.fsetdec. + by move=> ??; apply: hvm2. - move: hres; rewrite -(sem_pexprs_get_var gd) => hres. - have [| vres1 hres' ures1]:= sem_pexprs_uincl_on (vmap_uincl_onI _ hvm3) hres. + move: hres; rewrite -(sem_pexprs_get_var _ gd) => hres. + have [| vres1 hres' ures1]:= sem_pexprs_uincl_on (uincl_onI _ hvm3) hres. + by rewrite vars_l_read_es; SvD.fsetdec. - have [vres1' hcr' uvres1'] := mapM2_truncate_val hcr ures1. + have [vres1' hcr' uvres1'] := mapM2_dc_truncate_val hcr ures1. move: hi hget' hca' hw' hc' hres' hcr' hscs hfi. - rewrite (sem_pexprs_get_var gd) => hi hget' hca' hw' hc' hres' hcr' hscs hfi. + rewrite (sem_pexprs_get_var _ gd) => hi hget' hca' hw' hc' hres' hcr' hscs hfi. exists vres1' => //; econstructor; eauto => /=. by rewrite -hpex; case: (s0) hi. Qed. diff --git a/proofs/compiler/array_expansion.v b/proofs/compiler/array_expansion.v index 3e9a1f15b..7dd26b9c8 100644 --- a/proofs/compiler/array_expansion.v +++ b/proofs/compiler/array_expansion.v @@ -10,8 +10,6 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope vmap. - Local Open Scope seq_scope. Module Import E. @@ -47,21 +45,12 @@ Module Import E. pel_internal := true |}. + Definition length_mismatch := pp_internal_error_s pass "length mismatch". + Definition reg_ierror_no_var := pp_internal_error_s pass. End E. -Module CmpIndex. - - Definition t := [eqType of Z]. - - Definition cmp : t -> t -> comparison := Z.compare. - - Lemma cmpO : Cmp cmp. - Proof. apply ZO. Qed. - -End CmpIndex. - Record varr_info := { vi_v : var; vi_s : wsize; @@ -71,13 +60,13 @@ Record varr_info := { Record expand_info := { vars : list var; arrs : list varr_info; + finfo : fun_info; }. -Module Mi := gen_map.Mmake CmpIndex. - Record array_info := { - ai_ty : wsize; - ai_elems : Mi.t var; + ai_ty : wsize; + ai_len : Z; + ai_elems : list var; }. Record t := { @@ -85,35 +74,36 @@ Record t := { sarrs : Mvar.t array_info; }. -Definition of_list (l: list var) := - foldl (fun s x => Sv.add x s) Sv.empty l. +Definition expd_t := (Mf.t (seq (option (wsize * Z)) * seq (option (wsize * Z)))). -Definition init_elems ty id (svmi : Sv.t * Mi.t var * Z) := - let '(sv,mi,i) := svmi in - let xi := {| vtype := ty; vname := id |} in +Definition init_elems xi (svmi : Sv.t * Z) := + let '(sv,i) := svmi in Let _ := assert (~~ Sv.mem xi sv) (reg_ierror_no_var "init_elems") in - ok (Sv.add xi sv, Mi.set mi i xi, (i + 1)%Z). + ok (Sv.add xi sv, (i + 1)%Z). Definition init_array_info (x : varr_info) (svm:Sv.t * Mvar.t array_info) := let (sv,m) := svm in let ty := sword x.(vi_s) in Let _ := assert (~~ Sv.mem x.(vi_v) sv) (reg_ierror_no_var "init_array_info") in - Let svelems := foldM (init_elems ty) (sv,Mi.empty _,0%Z) x.(vi_n) in - let '(sv, mi, _) := svelems in - ok (sv, Mvar.set m x.(vi_v) {| ai_ty := x.(vi_s); ai_elems := mi |}). + let vars := map (fun id => {| vtype := ty; vname := id |}) x.(vi_n) in + Let svelems := foldM init_elems (sv,0%Z) vars in + let '(sv, len) := svelems in + Let _ := assert [&& (0 x) fi.(vars) in Let sarrs := foldM init_array_info (svars, Mvar.empty _) fi.(arrs) in - ok {| svars := svars; sarrs := sarrs.2 |}. + ok ({| svars := svars; sarrs := sarrs.2 |}, finfo fi). Definition check_gvar (m : t) (x: gvar) := ~~ is_lvar x || Sv.mem (gv x) m.(svars). Definition nelem (ty: stype) (ws: wsize) : Z := - if ty is sarr n - then n / wsize_size ws - else 0. + if ty is sarr n + then n / wsize_size ws + else 0. (* FIXME: improve error messages *) Fixpoint expand_e (m : t) (e : pexpr) : cexec pexpr := @@ -134,11 +124,9 @@ Fixpoint expand_e (m : t) (e : pexpr) : cexec pexpr := | Some ai, Some i => Let _ := assert (ai.(ai_ty) == ws) (reg_error x "(the default scale must be used)") in Let _ := assert (aa == AAscale) (reg_error x "(the default scale must be used)") in - Let _ := assert ((0 <=? i) && (i ok (Pvar (mk_lvar {| v_var := v; v_info := v_info x |})) - | _ => Error (reg_ierror x "the new variable was not given") - end + Let _ := assert [&& 0 <=? i & i Error (reg_error x "(the index is not a constant)") end @@ -195,11 +183,9 @@ Definition expand_lv (m : t) (x : lval) := | Some ai, Some i => Let _ := assert (ai.(ai_ty) == ws) (reg_error x "(the default scale must be used)") in Let _ := assert (aa == AAscale) (reg_error x "(the default scale must be used)") in - Let _ := assert ((0 <=? i) && (i ok (Lvar {| v_var := v; v_info := v_info x |}) - | _ => Error (reg_ierror x "the new variable was not given") - end + Let _ := assert [&& 0 <=? i & i Error (reg_error x "(the index is not a constant)") end @@ -214,9 +200,77 @@ Definition expand_es m := mapM (expand_e m). Definition expand_lvs m := mapM (expand_lv m). +Definition expand_param (m : t) ex (e : pexpr) : cexec _ := + let erre {A} x := @Error _ A (reg_ierror (gv x) "variable cannot be expanded") in + match ex with + | Some (ws, len) => + match e with + | Pvar x => + let vi := v_info (gv x) in + oapp (fun ai => + if [&& ws == ai_ty ai, len == ai_len ai & is_lvar x] + then ok (map (fun v => Pvar (mk_lvar (VarI v vi))) (ai_elems ai)) + else Error (reg_ierror (gv x) "type mismatch")) (erre x) (Mvar.get m.(sarrs) (gv x)) + | Psub aa ws' len' x e => + Let _ := assert (aa == AAscale) (reg_error (gv x) "(the default scale must be used)") in + match is_const e with + | Some i => + let vi := v_info (gv x) in + oapp (fun ai => + Let _ := assert [&& ws == ai_ty ai, ws' == ws, len == len' & is_lvar x] + (reg_ierror (gv x) "type mismatch") in + let elems := take (Z.to_nat len) (drop (Z.to_nat i) (ai_elems ai)) in + ok (map (fun v => Pvar (mk_lvar (VarI v vi))) elems)) + (erre x) (Mvar.get m.(sarrs) (gv x)) + | None => + Error (reg_error (gv x) "(the index is not a constant)") + end + + | _ => + Error (reg_ierror_no_var "only variables and sub arrays can be expanded in function arguments") + end + | None => rmap (fun x => [:: x]) (expand_e m e) + end. + +Definition expand_return m ex x := + let erre {A} x := @Error _ A (reg_ierror x "variable cannot be expanded") in + match ex with + | Some (ws, len) => + match x with + | Lnone v t => ok (nseq (Z.to_nat len) (Lnone v (sword ws))) + | Lvar x => + let vi := v_info x in + oapp (fun ai => + if [&& ws == ai_ty ai & len == ai_len ai] + then ok (map (fun v => Lvar (VarI v vi)) (ai_elems ai)) + else Error (reg_ierror x "type mismatch")) (erre x) (Mvar.get m.(sarrs) x) + | Lasub aa ws' len' x e => + Let _ := assert (aa == AAscale) (reg_error x "(the default scale must be used)") in + match is_const e with + | Some i => + let vi := v_info x in + oapp (fun ai => + Let _ := assert [&& ws == ai_ty ai, ws' == ws & len == len'] + (reg_ierror x "type mismatch") in + let elems := take (Z.to_nat len) (drop (Z.to_nat i) (ai_elems ai)) in + ok (map (fun v => Lvar (VarI v vi)) elems)) + (erre x) (Mvar.get m.(sarrs) x) + | None => + Error (reg_error x "(the index is not a constant)") + end + + | _ => Error (reg_ierror_no_var "only variables/sub-arrays/_ can be expanded in function return") + end + | None => rmap (fun x => [:: x]) (expand_lv m x) + end. + Section ASM_OP. -Context `{asmop:asmOp}. +Context `{asmop : asmOp}. + +Section FSIGS. + +Context (fsigs : expd_t). Fixpoint expand_i (m : t) (i : instr) : cexec instr := let (ii,ir) := i in @@ -256,28 +310,59 @@ Fixpoint expand_i (m : t) (i : instr) : cexec instr := ok (MkI ii (Cwhile a c e c')) | Ccall ini xs fn es => - Let xs := add_iinfo ii (expand_lvs m xs) in - Let es := add_iinfo ii (expand_es m es) in - ok (MkI ii (Ccall ini xs fn es)) + if Mf.get fsigs fn is Some (expdin, expdout) then + Let xs := add_iinfo ii (rmap flatten (mapM2 length_mismatch (expand_return m) expdout xs)) in + Let es := add_iinfo ii (rmap flatten (mapM2 length_mismatch (expand_param m) expdin es)) in + ok (MkI ii (Ccall ini xs fn es)) + else Error (reg_ierror_no_var "function not found") end. -Definition expand_fd (fi : funname -> ufundef -> expand_info) (f : funname) (fd: ufundef) := - Let m := init_map (fi f fd) in +Definition expand_tyv m b ty v := + if Mvar.get m.(sarrs) (v_var v) is Some ai then + Let _ := assert b (reg_ierror v "expansion would modify signature of an exported function") in + let vi := v_info v in + let vvars := map (fun v' => VarI v' vi) (ai_elems ai) in + let vtypes := map vtype (ai_elems ai) in + ok (vtypes, vvars, Some (ai_ty ai, ai_len ai)) + else + Let _ := assert (Sv.mem (v_var v) m.(svars)) + (reg_ierror v "there should be an invariant ensuring this never happens in array_expansion_proof") in + ok ([:: ty], [:: v], None). + +Definition expand_fsig fi (entries : seq funname) (fname: funname) (fd: ufundef) := + Let x := init_map (fi fname fd) in match fd with - | MkFun fi tyin params c tyout res ef => - Let _ := - assert (all (fun x => Sv.mem (v_var x) m.(svars)) params) - (reg_ferror fi "reg arrays are not allowed in parameters of non inlined function") in - Let _ := - assert (all (fun x => Sv.mem (v_var x) m.(svars)) res) - (reg_ferror fi "reg arrays are not allowed in the return type of non inlined function") in + | MkFun _ tyin params c tyout res ef => + let '(m, fi) := x in + let exp := ~~(fname \in entries) in + Let ins := mapM2 length_mismatch (expand_tyv m exp) tyin params in + let tyin := map (fun x => fst (fst x)) ins in + let params := map (fun x => snd (fst x)) ins in + let ins := map snd ins in + Let outs := mapM2 length_mismatch (expand_tyv m exp) tyout res in + let tyout := map (fun x => fst (fst x)) outs in + let res := map (fun x => snd (fst x)) outs in + let outs := map snd outs in + ok (MkFun fi (flatten tyin) (flatten params) c (flatten tyout) (flatten res) ef, + m, (ins, outs)) + end. +Definition expand_fbody (fname: funname) (fs: ufundef * t) := + let (fd, m) := fs in + match fd with + | MkFun fi tyin params c tyout res ef => Let c := mapM (expand_i m) c in ok (MkFun fi tyin params c tyout res ef) end. -Definition expand_prog (fi : funname -> ufundef -> expand_info) (p: uprog) : cexec uprog := - Let funcs := map_cfprog_name (expand_fd fi) (p_funcs p) in +End FSIGS. + +Notation map_cfprog_name_cdata := (map_cfprog_name_gen (fun x => @f_info _ _ _ (fst (fst x)))). + +Definition expand_prog (fi : funname -> ufundef -> expand_info) (entries : seq funname) (p: uprog) : cexec uprog := + Let step1 := map_cfprog_name (expand_fsig fi entries) (p_funcs p) in + let fsigs := foldr (fun x y => Mf.set y x.1 x.2.2) (Mf.empty _) step1 in + Let funcs := map_cfprog_name_cdata (fun fn x => expand_fbody fsigs fn (fst x)) step1 in ok {| p_extra := p_extra p; p_globs := p_globs p; p_funcs := funcs |}. End ASM_OP. diff --git a/proofs/compiler/array_expansion_proof.v b/proofs/compiler/array_expansion_proof.v index 1570f5874..2d1b315a1 100644 --- a/proofs/compiler/array_expansion_proof.v +++ b/proofs/compiler/array_expansion_proof.v @@ -8,77 +8,153 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope vmap. Local Open Scope seq_scope. -Definition wf_t (m : t) := - forall x ai, Mvar.get m.(sarrs) x = Some ai -> - ~ Sv.mem x m.(svars) /\ - forall i xi, Mi.get ai.(ai_elems) i = Some xi -> - ~ Sv.mem xi m.(svars) /\ - xi.(vtype) == sword ai.(ai_ty) /\ - forall x' ai' i' xi', - Mvar.get m.(sarrs) x' = Some ai' -> - Mi.get ai'.(ai_elems) i' = Some xi' -> - x <> x' \/ i <> i' -> xi != xi'. - -Definition set_undef_e (t:stype) (v : exec (psem_t t)) := - match v with - | Ok v => ok v - | _ => Error ErrAddrUndef +Record wf_ai (m : t) (x:var) ai := { + x_nin : ~ Sv.In x m.(svars); + len_pos : (0 < ai.(ai_len))%Z; + len_def : ai_len ai = Z.of_nat (size (ai_elems ai)); + x_ty : vtype x = sarr (Z.to_pos (arr_size ai.(ai_ty) (Z.to_pos ai.(ai_len)))); + xi_nin : forall xi, xi \in ai_elems ai -> ~ Sv.In xi m.(svars); + xi_ty : forall xi, xi \in ai_elems ai -> xi.(vtype) = sword ai.(ai_ty); + el_uni : uniq (ai_elems ai); + xi_disj : forall x' ai' xi, x <> x' -> Mvar.get m.(sarrs) x' = Some ai' -> + ~(xi \in ai_elems ai /\ xi \in ai_elems ai') +}. + +Definition wf_t (m : t) := + forall x ai, Mvar.get m.(sarrs) x = Some ai -> wf_ai m x ai. + +Definition eval_array ws v i := + if v is Varr _ t + then ok (rdflt undef_w (rmap (@Vword _) (WArray.get AAscale ws t i))) + else type_error. + +Definition eq_alloc_vm {wsw : WithSubWord} (m : t) vm1 vm2 := + vm1 =[m.(svars)] vm2 /\ + forall x ai xi, + Mvar.get m.(sarrs) x = Some ai -> + xi \in ai.(ai_elems) -> + eval_array ai.(ai_ty) vm1.[x] (zindex xi ai.(ai_elems)) = ok vm2.[xi]. + +Definition expand_v expd v := + match expd with + | Some (ws, len) => mapM (eval_array ws v) (ziota 0 len) + | None => ok [:: v] end. -Definition eval_array (vm : vmap) ws x i := - @on_arr_var _ (get_var vm x) - (fun n (t:WArray.array n) => - Let w := WArray.get AAscale ws t i in - ok (pword_of_word w)). +Definition expand_vs := mapM2 ErrType expand_v. -Definition eq_alloc_vm (m : t) (vm1 vm2 : vmap) := - vm1 =[m.(svars)] vm2 /\ - forall x ai i xi, - Mvar.get m.(sarrs) x = Some ai -> - Mi.get ai.(ai_elems) i = Some xi -> - eval_uincl (set_undef_e (t := sword ai.(ai_ty)) (eval_array vm1 ai.(ai_ty) x i)) - (set_undef_e vm2.[xi]). +(* ---------------------------------------------------------------------- *) + +Lemma eval_arrayP ws v i w : eval_array ws v i = ok w -> + is_sarr (type_of_val v) /\ (w = undef_w \/ exists ww, w = @Vword ws ww). +Proof. + by case: v => //= > [<-]; split=> //; case: WArray.get; auto; right; eexists. +Qed. + +Lemma wf_mem dfl m x ax i : + wf_ai m x ax -> + [&& 0 <=? i & i + znth dfl ax.(ai_elems) i \in ax.(ai_elems). +Proof. move=> hai; rewrite hai.(len_def); apply mem_znth. Qed. + +Lemma wf_index dfl m x ax i: + wf_ai m x ax -> + (0 <=? i)%Z && (i + zindex (znth dfl (ai_elems ax) i) (ai_elems ax) = i. +Proof. + move=> hai; rewrite /zindex hai.(len_def) => /andP[] /ZleP ? /ZltP ?. + rewrite znthE // index_uniq. + + by apply Z2Nat.id. + + by apply/ZNltP;rewrite Z2Nat.id. + apply hai.(el_uni). +Qed. + +Lemma zindex_bound m x ai y: + wf_ai m x ai -> + let k := zindex y (ai_elems ai) in + ((0 <=? k)%Z && (k hva /=; rewrite -index_mem. + apply Bool.eq_iff_eq_true; split. + + by move=> /andP [] _ /ZltP ?; apply/ZNltP; rewrite -/(zindex y (ai_elems ai)) -hva.(len_def). + by move=> /ZNltP; rewrite (len_def hva) => h; apply /andP; split; [apply/ZleP/Zle_0_nat | apply/ZltP]. +Qed. + +Lemma wf_take_drop dfl m x ai i len : + wf_ai m x ai -> + (0 <= i)%Z -> (i + len <= ai_len ai)%Z -> (0 <= len)%Z -> + take (Z.to_nat len) (drop (Z.to_nat i) (ai_elems ai)) = + map (fun j => znth dfl (ai_elems ai) (i + j)) (ziota 0 len). +Proof. + move=> vai h0i hilen h0len. + have heq : size (take (Z.to_nat len) (drop (Z.to_nat i) (ai_elems ai))) = Z.to_nat len. + + rewrite size_takel // size_drop; apply/ZNleP. + rewrite Nat2Z.n2zB. + + by rewrite -vai.(len_def) !Z2Nat.id // -subZE; Psatz.lia. + by apply/ZNleP; rewrite -vai.(len_def) !Z2Nat.id //; Psatz.lia. + apply (eq_from_nth (x0:= dfl)). + + by rewrite size_map size_ziota. + move=> j; rewrite heq => hj. + rewrite nth_take // nth_drop (nth_map 0%Z) ?size_ziota // nth_ziota // /= znthE; last by Psatz.lia. + rewrite Z2Nat.inj_add // ?Nat2Z.id //; apply Zle_0_nat. +Qed. + +Lemma wf_ai_elems dfl m x ai : + wf_ai m x ai -> + ai_elems ai = map (fun j => znth dfl (ai_elems ai) j) (ziota 0 ai.(ai_len)). +Proof. + move=> vai. + have /= := @wf_take_drop dfl m x ai 0 ai.(ai_len) vai (Z.le_refl _) (Z.le_refl _). + rewrite vai.(len_def) => /(_ (Zle_0_nat _)) <-. + by rewrite drop0 Nat2Z.id take_size. +Qed. + +Lemma expand_vP n a ws l : + mapM (eval_array ws (@Varr n a)) l = + ok (map (fun i => rdflt undef_w (rmap (@Vword _) (WArray.get AAscale ws a i))) l). +Proof. by elim: l => // *; simpl map; rewrite -mapM_cons. Qed. -Definition eq_alloc - {asm_op syscall_state : Type} - {ep : EstateParams syscall_state} - {spp : SemPexprParams} - {sip : SemInstrParams asm_op syscall_state} - (m : t) - (s1 s2 : estate) := - [/\ eq_alloc_vm m s1.(evm) s2.(evm), - s1.(escs) = s2.(escs) & s1.(emem) = s2.(emem)]. Section WITH_PARAMS. Context + {wsw : WithSubWord} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} {sip : SemInstrParams asm_op syscall_state} (fi : funname -> ufundef -> expand_info) + (entries : seq funname) (p1 p2 : uprog). +#[local] Existing Instance direct_c. + +Definition eq_alloc (m : t) (s1 s2 : estate) := + [/\ eq_alloc_vm m s1.(evm) s2.(evm), + s1.(escs) = s2.(escs) & s1.(emem) = s2.(emem)]. + Local Notation gd := (p_globs p1). Section Expr. Context (m : t) (valid : wf_t m). +Section WDB. + +Context (wdb : bool). + Lemma check_var_get s1 s2 x : Sv.mem x (svars m) -> eq_alloc m s1 s2 -> - get_var (evm s1) x = get_var (evm s2) x. + get_var wdb (evm s1) x = get_var wdb (evm s2) x. Proof. by move=> /Sv_memP hin -[] [] heq _ _; rewrite /get_var /= heq. Qed. - Lemma check_var_gets s1 s2 xs : all (fun (x:var_i) => Sv.mem x (svars m)) xs -> eq_alloc m s1 s2 -> - mapM (fun (x:var_i) => get_var (evm s1) x) xs = mapM (fun (x:var_i) => get_var (evm s2) x) xs. + mapM (fun (x:var_i) => get_var wdb (evm s1) x) xs = mapM (fun (x:var_i) => get_var wdb (evm s2) x) xs. Proof. move=> hall heqa; elim: xs hall => //= x xs hrec /andP []. by move=> /(check_var_get) -/(_ _ _ heqa) -> /hrec ->. @@ -87,7 +163,7 @@ Qed. Lemma check_gvar_get s1 s2 x : check_gvar m x -> eq_alloc m s1 s2 -> - get_gvar gd s1.(evm) x = get_gvar gd s2.(evm) x. + get_gvar wdb gd s1.(evm) x = get_gvar wdb gd s2.(evm) x. Proof. rewrite /get_gvar /check_gvar; case: is_lvar => //=; apply check_var_get. Qed. Lemma eq_alloc_mem s1 s2 : eq_alloc m s1 s2 -> emem s1 = emem s2. @@ -96,121 +172,92 @@ Proof. by case. Qed. Lemma eq_alloc_scs s1 s2 : eq_alloc m s1 s2 -> escs s1 = escs s2. Proof. by case. Qed. -Lemma expand_esP_aux (s1 s2 : estate) es1 es2: - eq_alloc m s1 s2 -> - expand_es m es1 = ok es2 -> - (∀ e, List.In e es1 → - ∀ e2, expand_e m e = ok e2 → - ∀ v, sem_pexpr gd s1 e = ok v → sem_pexpr gd s2 e2 = ok v) -> - forall vs, sem_pexprs gd s1 es1 = ok vs -> sem_pexprs gd s2 es2 = ok vs. -Proof. - move=> h; rewrite /sem_pexprs /expand_es. - elim: es1 es2 => [ | e1 es1 hrec] es' /=. - + by move=> [<-] _ ? [<-]. - t_xrbindP => e2 he1 es2 /hrec hes1 <- he ?? se1 ? /hes1 hes2 <- /=. - rewrite (he _ _ _ he1 _ se1); last by left. - by rewrite /= hes2 // => e he'; apply: he; right. -Qed. +Section EXPR. -Lemma expand_eP (s1 s2: estate) : - eq_alloc m s1 s2 -> - forall e1 e2, expand_e m e1 = ok e2 -> - forall v, sem_pexpr gd s1 e1 = ok v -> - sem_pexpr gd s2 e2 = ok v. -Proof. - move=> h; elim => /=. - + by move=> z _ [<-] _ [<-]. - + by move=> b _ [<-] _ [<-]. - + by move=> n _ [<-] _ [<-]. - + by move=> x e2; t_xrbindP => /check_gvar_get -/(_ _ _ h) -> <-. +Context (s1 s2 : estate) (h : eq_alloc m s1 s2). + +Let P e1 := + forall e2, expand_e m e1 = ok e2 -> + forall v, sem_pexpr wdb gd s1 e1 = ok v -> + sem_pexpr wdb gd s2 e2 = ok v. + +Let Q es1 := + forall es2, expand_es m es1 = ok es2 -> + forall v, sem_pexprs wdb gd s1 es1 = ok v -> + sem_pexprs wdb gd s2 es2 = ok v. + + +Lemma expand_eP_and : (forall e, P e) /\ (forall es, Q es). +Proof. + apply: pexprs_ind_pair; subst P Q; split => //=; t_xrbindP. + + by move=> > <- > <-. + + by move=> > he > hes > hex > hexs <- > /(he _ hex) /= -> > /(hes _ hexs) /= -> <-. + + by move=> z _ <- _ <-. + + by move=> b _ <- _ <-. + + by move=> n _ <- _ <-. + + by move=> > /(check_gvar_get) -/(_ _ _ h) -> <-. + move=> aa sz x e hrec e2. - case heq : check_gvar. - + have hx := check_gvar_get heq h. - t_xrbindP => e1 /hrec he <- v /=. - rewrite hx; apply on_arr_gvarP => n t hty -> /=. - by t_xrbindP => i vi /he -> /= -> /= w -> <-. - case hgetx : Mvar.get => [ai | //]. - case: (is_constP e) => // i. - t_xrbindP => /eqP <- /eqP -> bc. - case hgeti : Mi.get => [xi | //] [<-] v. - apply on_arr_gvarP => n t hty hx /=. - t_xrbindP => w hw <-; case: h => -[] _ /(_ _ _ _ _ hgetx hgeti). - rewrite /get_gvar /= /get_var. - have [hnin /(_ _ _ hgeti) [hnini [htyi _]] {hgeti}] := valid hgetx. - case: xi htyi hnini => /= _ nxi /eqP -> hnini. - rewrite /on_vu /= /eval_array. - move/negbT: heq hx; rewrite /get_gvar negb_or => /andP []/negbNE -> _. - rewrite /get_var /on_vu /= => -> /=; rewrite hw /=. - case: (evm s2).[ _ ] => //= wi; rewrite /pval_uincl /=. - rewrite /word_uincl => /andP; case: wi => wsi wi h3 /= [] h4 /eqP -> _. - by have <- := cmp_le_antisym h3 h4; rewrite zero_extend_u. - + move=> aa sz len x e hrec e2. - t_xrbindP => he e1 /hrec hrec1 <- /=. + case: ifP => [/check_gvar_get /(_ h)|/norP/proj1/negbNE hlv]. + + t_xrbindP=> -> e1 /hrec he <- v /=. + apply: on_arr_gvarP => n t hty ->. + by t_xrbindP=> i vi /he -> /= -> /= w -> <-. + case hgetx : Mvar.get => [ax|//]; case: is_constP => // i. + t_xrbindP=> /eqP <- /eqP -> hbound <- v; have hai := valid hgetx. + apply: on_arr_gvarP => n t /eqP hty. + rewrite /get_gvar hlv{hlv} => /get_varP [ hx1 _ _] /=. + t_xrbindP=> ? hw <-. + case: h=> -[_] /(_ _ _ _ hgetx (wf_mem (v_var (gv x)) hai hbound)). + by rewrite -hx1 /= (wf_index _ hai hbound) /get_gvar /get_var hw /= => -[<-] /=; rewrite orbT. + + move=> aa sz len x e hrec e2 he e1 /hrec hrec1 <- /=. rewrite (check_gvar_get he h) => v. apply on_arr_gvarP => n t hty -> /=. by t_xrbindP => i vi /hrec1 -> /= -> t' /= -> <-. - + move=> sz x e hrec e2. - t_xrbindP => hin e1 /hrec hrec1 <- /=. + + move=> sz x e hrec e2 hin e1 /hrec hrec1 <- /=. move=> v p vp; rewrite (check_var_get hin h) => -> /= -> /= i vi /hrec1 -> /= -> /=. by rewrite (eq_alloc_mem h) => ? -> <-. - + by move=> o e1 hrec e2; t_xrbindP => e1' /hrec he1 <- /= ?? /he1 -> /= ->. - + move=> o e1 hrec1 e2 hrec2 e'. - by t_xrbindP => e1' /hrec1 he1 e2' /hrec2 he2 <- /= ?? /he1 -> /= ? /he2 -> /=. - + move=> op es hrec e'; t_xrbindP => es' hes' <- ?? h1 h2 /=. - by have := expand_esP_aux h hes' hrec h1; rewrite /sem_pexprs => ->. - move=> t b hrecb e1 hrec1 e2 hrec2 e'. - t_xrbindP => b' /hrecb hb e1' /hrec1 he1 e2' /hrec2 he2 <- /=. + + by move=> o e1 hrec e2 e1' /hrec he1 <- /= ?? /he1 -> /= ->. + + by move=> o e1 hrec1 e2 hrec2 e' e1' /hrec1 he1 e2' /hrec2 he2 <- /= ?? /he1 -> /= ? /he2 -> /=. + + by move=> op es hrec e' es' hes' <- ?? /(hrec _ hes') /=; rewrite /sem_pexprs => -> /= ->. + move=> t b hrecb e1 hrec1 e2 hrec2 e' b' /hrecb hb e1' /hrec1 he1 e2' /hrec2 he2 <- /=. by move=> ??? /hb -> /= -> /= ?? /he1 -> /= -> ?? /he2 -> /= -> /= <-. Qed. -Lemma expand_esP (s1 s2 : estate) : - eq_alloc m s1 s2 -> - forall es1 es2, expand_es m es1 = ok es2 -> - forall vs, sem_pexprs gd s1 es1 = ok vs -> - sem_pexprs gd s2 es2 = ok vs. -Proof. by move=> h es1 es2 hex; apply (expand_esP_aux h hex) => e _; apply expand_eP. Qed. +Lemma expand_eP e : P e. +Proof. by case: expand_eP_and. Qed. + +Lemma expand_esP e : Q e. +Proof. by case: expand_eP_and. Qed. + +End EXPR. Lemma eq_alloc_write_var s1 s2 (x: var_i) v s1': eq_alloc m s1 s2 -> Sv.mem x (svars m) -> - write_var x v s1 = ok s1' -> - ∃ s2' : estate, write_var x v s2 = ok s2' ∧ eq_alloc m s1' s2'. + write_var wdb x v s1 = ok s1' -> + ∃ s2' : estate, write_var wdb x v s2 = ok s2' ∧ eq_alloc m s1' s2'. Proof. move=> h; case: (h) => -[heq ha] hscs hmem /=. move=> /Sv_memP hin hw. - have [vm2 [heq2 hw2]]:= write_var_eq_on hw heq. + have [vm2 hw2 heq2]:= write_var_eq_on hw heq. exists (with_vm s1' vm2); split. + have -> // : s2 = with_vm s1 (evm s2) by case: (s2) hscs hmem => ??? /= <- <-. split => //; split; first by apply: eq_onI heq2; SvD.fsetdec. - move=> x' ai i xi hai hxi. - have [/negP /Sv_memP hnx' /(_ _ _ hxi) [] /negP /Sv_memP hnxi _]:= valid hai. - rewrite /eval_array /= /on_arr_var /get_var. + move=> x' ai xi hai hxi. + have vai := valid hai; move: vai.(x_nin) (vai.(xi_nin) hxi) => hnx' hnxi. rewrite -(vrvP_var hw); last by SvD.fsetdec. - have /= <- := (vrvP_var hw2); last by SvD.fsetdec. - by apply: ha. -Qed. - -Lemma eq_alloc_write_vars s1 s2 (xs: list var_i) vs s1': - eq_alloc m s1 s2 -> - all (fun (x:var_i) => Sv.mem x (svars m)) xs -> - write_vars xs vs s1 = ok s1' -> - ∃ s2' : estate, write_vars xs vs s2 = ok s2' ∧ eq_alloc m s1' s2'. -Proof. - elim: xs vs s1 s2 s1' => /= [ | x xs hrec] [ | v vs] // s1 s2 s1' heqa. - + by move=> _ [<-]; exists s2. - move=> /andP [hx hall]; t_xrbindP => s1'' /(eq_alloc_write_var heqa hx) [s2'' [hw heqa']]. - by move=> /(hrec _ _ _ _ heqa' hall) [s2' [hws ?]]; exists s2'; rewrite hw /= hws /=. + rewrite -(vrvP_var hw2); last by SvD.fsetdec. + by apply ha. Qed. Lemma expand_lvP (s1 s2 : estate) : eq_alloc m s1 s2 -> forall x1 x2, expand_lv m x1 = ok x2 -> forall v s1', - write_lval gd x1 v s1 = ok s1' -> - exists s2', write_lval gd x2 v s2 = ok s2' /\ eq_alloc m s1' s2'. + write_lval wdb gd x1 v s1 = ok s1' -> + exists s2', write_lval wdb gd x2 v s2 = ok s2' /\ eq_alloc m s1' s2'. Proof. move=> h; case: (h) => -[heq ha] hscs hmem [] /=. - + move=> ii ty _ [<-] /= ?? /dup [] /write_noneP [->] _ hn. + + move=> ii ty _ [<-] /= ?? /dup [] /write_noneP [-> _ _] hn. by exists s2; split => //; apply: uincl_write_none hn. + by move=> x; t_xrbindP => _ ? <- /= v1 s1'; apply eq_alloc_write_var. + move=> ws x e x2; t_xrbindP => hin e' he <- v s1' vx p /=. @@ -225,41 +272,43 @@ Proof. t_xrbindP => i vi /(expand_eP h he) -> /= -> /= ? -> /= t' -> hw. by apply (eq_alloc_write_var h hin hw). case hai: Mvar.get => [ai | //]. - case: is_constP => // i ; t_xrbindP => /eqP <- /eqP -> bc. - case hxi: Mi.get => [xi | //] [<-] v s1'. + case: is_constP => // i ; t_xrbindP => /eqP <- /eqP -> hbound <- v s1'. apply on_arr_varP => n t hty hget /=. - rewrite /write_var; t_xrbindP => w hvw t' ht' vm' hs <-. - have [_ /(_ _ _ hxi)]:= valid hai. - case: xi hxi => txi nxi; set xi := {| vname := _ |} => hxi [] hnxi /= [] /eqP ? hd; subst txi. - rewrite /write_var /set_var /= /on_vu (to_word_to_pword hvw) /=. - eexists; split; first by eauto. + t_xrbindP => w hvw t' ht' /dup[] hw1 /write_varP [? _ htrv]; subst s1'. + have vai := valid hai; have hin := wf_mem (v_var x) vai hbound. + move: (vai.(xi_ty) hin) (vai.(xi_nin) hin) => htyi ?. + have [htri htrvi hdb hdv]:= to_word_vm_truncate_val wdb htyi hvw. + set xi := znth (v_var x) (ai_elems ai) i. + have hw2 := write_var_truncate (x:= {| v_var := xi; v_info := v_info x |}) hdb htri s2. + eexists; split; first eauto. split => //; split. + apply: (eq_onT (vm2:= evm s1)). - + apply eq_onS. - apply: (disjoint_eq_on (gd := gd) (r := x) (v := Varr t')). - + by rewrite vrv_var; move/Sv_memP : hnin => hnin; apply/Sv.is_empty_spec; SvD.fsetdec. - by rewrite /= /write_var hs. + + apply eq_onS; apply: (disjoint_eq_on (wdb := wdb) (gd := gd) (r := x) (v := Varr t')) => //. + by rewrite vrv_var; move/Sv_memP : hnin => hnin; apply/Sv.is_empty_spec; SvD.fsetdec. apply: (eq_onT heq). apply: (disjoint_eq_on + (wdb := wdb) (gd := gd) (r := Lvar (VarI xi x.(v_info))) - (v := Vword w)). - + by rewrite vrv_var; move/negP/Sv_memP:hnxi => hnxi /=; apply/Sv.is_empty_spec; SvD.fsetdec. - by rewrite /= /write_var /set_var /= /on_vu (sumbool_of_boolET (cmp_le_refl _)). - move=> x' ai' i' xi'. - rewrite /eval_array/on_arr_var /= (get_var_set_var _ hs). - case: ((v_var x) =P x') => [<- | hxx']. - + rewrite hai => -[<-]. - rewrite hty /pof_val /= WArray.castK /=. + (v := v)) => //. + rewrite vrv_var /= /xi; apply/Sv.is_empty_spec; SvD.fsetdec. + move=> x' ai' xi' hx' hxi'. + rewrite /eval_array/on_arr_var /=. + have [htri' htrvi' hdb' hdv']:= to_word_vm_truncate_val true htyi hvw. + rewrite Vm.setP //; case: eqP => hxx'. + + subst x'; move: hx'; rewrite hai => -[?]; subst ai'. + rewrite hty /= eqxx. rewrite (WArray.setP _ ht'). - case: (i =P i') => [<- /= | hii' hxi']. - + by rewrite hxi => -[<-]; rewrite Fv.setP_eq /=. - rewrite Fv.setP_neq. - + by have := ha _ _ _ _ hai hxi'; rewrite /eval_array /on_arr_var hget. - by apply (hd _ _ _ _ hai hxi'); auto. - move=> hai' hxi'; rewrite Fv.setP_neq; first by apply: ha hai' hxi'. - by apply (hd _ _ _ _ hai' hxi'); auto. + rewrite Vm.setP; case: (xi =P xi') => hxixi'. + + by subst xi'; rewrite (wf_index _ vai hbound) eqxx htrvi'. + case: eqP => ?. + + by subst i; elim hxixi'; rewrite /xi znth_index. + have := ha _ _ _ hai hxi'; rewrite /eval_array. + by move/get_varP: hget => [<-]. + rewrite Vm.setP_neq; first by apply: ha hx' hxi'. + have /(_ xi) hn := vai.(xi_disj) hxx' hx'. + by apply /eqP => ?; subst xi'; apply hn. move=> aa ws len x e x2; t_xrbindP => hin e' he <- /= v s1'. apply on_arr_varP => n t hty. rewrite (check_var_get hin h) => -> /=. @@ -271,8 +320,8 @@ Lemma expand_lvsP (s1 s2 : estate) : eq_alloc m s1 s2 -> forall x1 x2, expand_lvs m x1 = ok x2 -> forall vs s1', - write_lvals gd s1 x1 vs = ok s1' -> - exists s2', write_lvals gd s2 x2 vs = ok s2' /\ eq_alloc m s1' s2'. + write_lvals wdb gd s1 x1 vs = ok s1' -> + exists s2', write_lvals wdb gd s2 x2 vs = ok s2' /\ eq_alloc m s1' s2'. Proof. move=> heqa x1 x2 hex; elim: x1 x2 hex s1 s2 heqa => /=. + by move=> ? [<-] s1 s2 ? [ | //] ? [<-]; exists s2. @@ -281,70 +330,290 @@ Proof. by exists s2'; split => //=; rewrite hw. Qed. +End WDB. + +Opaque ziota. + +Lemma expand_paramsP (s1 s2 : estate) e expdin : + eq_alloc m s1 s2 -> + forall es1 es2 vs, mapM2 e (expand_param m) expdin es1 = ok es2 -> + sem_pexprs false gd s1 es1 = ok vs -> + exists2 vs', expand_vs expdin vs = ok vs' & + sem_pexprs false gd s2 (flatten es2) = ok (flatten vs'). +Proof. + move=> h ?? + H; elim: {H}(mapM2_Forall3 H) => [?[<-]|]; first by eexists. + move=> [] /=; last first. + + by t_xrbindP => > /(expand_eP h) {}h <- ? + hrec > /h{h} /= -> ? /hrec{hrec}[? + ->] <- /= => ->; eexists. + move=> [ws len] [] //=. + + move=> g c >; case: Option.oappP => // a1 hga; case: ifP => // + /and3P[/eqP? /eqP ? hloc] + _; subst; rewrite /get_gvar /=hloc{hloc} /=. + t_xrbindP=> + hrec ? z0 /hrec{hrec}+ <- => + [? ->] /= => <-. + have vai := (valid hga); case: h => -[_ /(_ _ _ _ hga){hga}hgai _ _]. + have := Vm.getP (evm s1) (gv g); rewrite vai.(x_ty) /compat_val /=. + move => /compat_typeE /type_of_valI [x2 /dup[] hg ->]. + rewrite /sem_pexprs mapM_cat -/(sem_pexprs _ _ _ (flatten _)) => -> /=. + rewrite expand_vP /=; eexists; eauto. + rewrite mapM_map /comp /= /get_gvar /get_var /= mapM_ok /=; do 2!f_equal. + rewrite (wf_ai_elems (v_var (gv g)) vai). + rewrite -map_comp; apply eq_in_map => i; rewrite in_ziota /comp /= => hbound. + move/hgai: (wf_mem (v_var (gv g)) vai hbound); rewrite hg /= => -[<-]. + by rewrite (wf_index _ vai hbound). + + move=> aa ws' len' g ei es >. + t_xrbindP => /eqP ?; subst aa. + case: is_constP => // i. + case: Option.oappP => // a hga. + t_xrbindP => /and4P [] /eqP ? /eqP ? /eqP ? hloc ? _ hrec vs z. subst ws ws' len es => /=. + have vai := valid hga. + +(* have [hninx [hlen hxty] hlena haxi huni hother]:= valid hga. *) + apply: on_arr_gvarP; rewrite vai.(x_ty) => len1 t [?]; subst len1. + rewrite /get_gvar hloc => /get_varP [hgx _ _]; t_xrbindP => st hst ?; subst z. + move=> ? /hrec[? hex +] <-; rewrite /sem_pexprs mapM_cat hex /= => -> /=. + rewrite expand_vP /=; eexists; eauto. + rewrite mapM_map /comp /= /get_gvar /get_var /= mapM_ok /=; do 2!f_equal. + have := WArray.get_sub_bound hst. + rewrite /arr_size /=. + move: t st hgx hst. + set wsaty := (X in (X * len')%positive). + set wsaty' := (X in (X * _)%positive). + have -> : wsaty' = wsaty by done. + have -> : Zpos (wsaty * len') = (wsize_size (ai_ty a) * Zpos len')%Z by done. + have -> : Zpos (wsaty * Z.to_pos (ai_len a))%positive = (wsize_size (ai_ty a) * ai_len a)%Z. + + by have ? := vai.(len_pos); rewrite Pos2Z.inj_mul Z2Pos.id. + move=> {wsaty'} t st hgx hst hi. + have ? := wsize_size_pos (ai_ty a). + rewrite -Z2Nat.inj_pos (wf_take_drop (v_var (gv g)) vai) //. 2,3: by Psatz.nia. + rewrite -map_comp; apply eq_in_map => j; rewrite in_ziota /comp /= => /andP [] /ZleP ? /ZltP ?. + have hbound : (0 <=? i + j)%Z && (i + j //; Psatz.nia. + case: h => -[_ /(_ _ _ _ hga){hga}hgai _ _]. + move/hgai: (wf_mem (v_var (gv g)) vai hbound); rewrite -hgx /= => -[<-]. + by rewrite (wf_index _ vai hbound) (WArray.get_sub_get hst). +Qed. + +Lemma wf_write_get s (x:var_i) ai (a : WArray.array (Z.to_pos (arr_size (ai_ty ai) (Z.to_pos (ai_len ai))))) i len : + wf_ai m x ai -> + (0 <= i)%Z -> (i + len <= ai_len ai)%Z -> (0 <= len)%Z -> + exists2 vm, + write_lvals false gd s [seq Lvar {| v_var := znth (v_var x) (ai_elems ai) x0; v_info := v_info x |} | x0 <- ziota i len] + [seq rdflt undef_w (rmap (Vword (s:=ai_ty ai)) (WArray.get AAscale (ai_ty ai) a i)) | i <- ziota i len] = ok (with_vm s vm) & + forall y, + vm.[y] = + let j := zindex y (ai_elems ai) in + if j \in ziota i len then + rdflt undef_w (rmap (Vword (s:=ai_ty ai)) (WArray.get AAscale (ai_ty ai) a j)) + else (evm s).[y]. +Proof. + move => hva h0i hilen h0l. + have : uniq (ziota i len). + + rewrite ziotaE map_inj_uniq ?iota_uniq //. + by move=> j1 j2 h; apply Nat2Z.inj; Psatz.lia. + elim/ziota_ind: (ziota _ _) s => /= [ | k l hk hrec] s. + + by move=> _; exists (evm s) => //; rewrite with_vm_same. + move=> /andP [] hkl huni. + rewrite /write_var /set_var /DB /=. + have hk1 : (0 <=? k)%Z && (k /= : (truncatable false (sword (ai_ty ai)) (rdflt undef_w (rmap (Vword (s:=ai_ty ai)) (WArray.get AAscale (ai_ty ai) a k)))). + + by case: WArray.get => //=. + set s1 := with_vm _ _. + case: (hrec s1 huni) => vm -> hvm; exists vm => // y; rewrite in_cons. + case: eqP => [he | hne] /=. + + move: (hk1); rewrite -he (zindex_bound y hva) => hyin. + rewrite hvm {1}he (negbTE hkl) /s1 /= -he znth_index // Vm.setP_eq. + rewrite (xi_ty hva hyin); case: WArray.get => /= ?. + + by rewrite cmp_le_refl orbT. + by apply (to_word_undef (s:=U8)). + rewrite hvm; case: ifPn => // _. + by rewrite /s1 /= Vm.setP_neq //; apply /eqP => ?; subst y; apply/hne/(wf_index _ hva hk1). +Qed. + +Opaque Z.mul. +Lemma expand_returnP (s1 s2 : estate) expdout : + eq_alloc m s1 s2 -> + forall x1 xs2, expand_return m expdout x1 = ok xs2 -> + forall v vs' s1', + write_lval false gd x1 v s1 = ok s1' -> + expand_v expdout v = ok vs' -> + exists2 s2', write_lvals false gd s2 xs2 vs' = ok s2' & + eq_alloc m s1' s2'. +Proof. + move=> heqa. + case: expdout => /=; last first. + + t_xrbindP => > /expand_lvP hlv <- > hw <- /=. + by have [? [-> ?] /=]:= hlv _ _ _ heqa _ _ hw; eauto. + move=> [a len] [] //. + + move=> > [<-] v1 vs ? /write_noneP [->] _ _ hm; exists s2 => //. + rewrite -(size_ziota 0) -map_const_nseq. + elim/ziota_ind: (ziota _ _) vs hm; first by move=> ? [<-]. + move=> /= > ? hrec; t_xrbindP => > /eval_arrayP [? h] ?/hrec{}hrec <-. + rewrite /write_none /= /truncatable. + by case: h => [-> | [? ->]] /=; rewrite ?wsize_le_U8. + + move=> x xs2; case: Option.oappP => // ai hga; have hva:= valid hga. + case: ifP => //= /andP[/eqP? /eqP?] [hmap] va vs' s1'; subst. + move=> /write_varP [-> _]. rewrite hva.(x_ty) => /vm_truncate_valEl [] a -> _. + rewrite expand_vP => -[?]; subst vs'. + rewrite (wf_ai_elems (v_var x) hva) -map_comp /comp. + have [vm2 -> hvm2 ]:= wf_write_get s2 a hva (Z.le_refl _) (Z.le_refl _) (Z.lt_le_incl _ _ (len_pos hva)). + eexists; eauto. + case heqa => heqv ??; split => //; split => /=. + + move=> y hin; rewrite hvm2 /= Vm.setP_neq; last by apply/eqP=> ?; subst y; apply (x_nin hva hin). + case: ifP; last by move=> _; apply heqv. + rewrite in_ziota /= (zindex_bound y hva). + by move=> /(xi_nin hva); elim. + move=> y ai' xi; rewrite hvm2 /= Vm.setP; case: eqP => [? | hne]; last first. + + move=> hga' hin'. + case: ifP; last by move=> _; apply heqv. + rewrite in_ziota /= (zindex_bound _ hva) => ?. + have /(_ xi):= xi_disj hva hne hga'; elim => //. + subst y; rewrite hga => -[<-] hin. + by rewrite in_ziota (zindex_bound _ hva) hin (x_ty hva) vm_truncate_val_eq. + move => aa ws' len' x e xs2; t_xrbindP => /eqP ?; subst aa. + case: is_constP => // i; case: Option.oappP => // ai hga; have hva:= valid hga. + t_xrbindP => /and3P []/eqP ? /eqP ? /eqP ? <- va vs' s1'; subst a ws' len. + have /= := Vm.getP (evm s1) x; rewrite hva.(x_ty) => /compat_valEl [a heqx]; rewrite heqx. + t_xrbindP => sa /to_arrI -> ra hra /write_varP [] -> _ _. + rewrite expand_vP => -[?]; subst vs'. + have := WArray.set_sub_bound hra. + have [ltws lt0len]:= (wsize_size_pos (ai_ty ai), len_pos hva). + rewrite /arr_size /mk_scale {1}(Z2Pos.id _ lt0len) Z2Pos.id; last by Psatz.nia. + move=> hb; have [{hb} h0i hilen'] : (0 <= i /\ i + len' <= ai_len ai)%Z by Psatz.nia. + have -> := wf_take_drop (v_var x) hva h0i hilen' (Zle_0_pos _). + rewrite -map_comp /comp. + have [vm2 ] := wf_write_get s2 ra hva h0i hilen' (Zle_0_pos _). + rewrite {1 2}(ziota_shift i len') -!map_comp /comp. + have -> : + [seq rdflt undef_w (rmap (Vword (s:=ai_ty ai)) (WArray.get AAscale (ai_ty ai) ra (i + x0))) | x0 <- ziota 0 len'] = + [seq rdflt undef_w (rmap (Vword (s:=ai_ty ai)) (WArray.get AAscale (ai_ty ai) sa i0)) | i0 <- ziota 0 len']. + + apply eq_in_map => j; rewrite in_ziota => /andP [] /ZleP ? /ZltP ?. + rewrite (WArray.set_sub_get hra). + have -> : (i <=? i + j)%Z && (i + j -> hvm2; eexists; eauto. + have hybound: forall y, + (i <=? zindex y (ai_elems ai))%Z && (zindex y (ai_elems ai) + (y \in ai_elems ai). + + move=> y => /andP [/ZleP ? /ZltP ?]; rewrite -(zindex_bound y hva). + by apply/andP; split; [apply/ZleP|apply/ZltP]; Psatz.nia. + case heqa => heqv ??; split => //; split => /=. + + move=> y hin; rewrite hvm2 /= Vm.setP_neq; last by apply/eqP=> ?; subst y; apply (x_nin hva hin). + case: ifP; last by move=> _; apply heqv. + by rewrite in_ziota /= => /hybound /(xi_nin hva); elim. + move=> y ai' xi; rewrite hvm2 /= Vm.setP; case: eqP => [? | hne]; last first. + + move=> hga' hin'. + case: ifP; last by move=> _; apply heqv. + rewrite in_ziota /= => /hybound ?. + have /(_ xi):= xi_disj hva hne hga'; elim => //. + subst y; rewrite hga => -[<-] hin. + rewrite in_ziota (x_ty hva); case: ifP => //=; rewrite eqxx //. + move: (hin); rewrite -(zindex_bound _ hva) => /andP [] /ZleP ? /ZltP ? hn. + rewrite /= (WArray.set_sub_get hra). + by rewrite hn; have [_ /(_ _ _ _ hga hin)]:= heqv; rewrite heqx. +Qed. + +Lemma expand_returnsP (s1 s2 : estate) e expdout : + eq_alloc m s1 s2 -> + forall xs1 xs2, mapM2 e (expand_return m) expdout xs1 = ok xs2 -> + forall vs vs' s1', + write_lvals false gd s1 xs1 vs = ok s1' -> + expand_vs expdout vs = ok vs' -> + exists2 s2', write_lvals false gd s2 (flatten xs2) (flatten vs') = ok s2' & + eq_alloc m s1' s2'. +Proof. + move=> + > H; elim: {H}(mapM2_Forall3 H) s1 s2. + + by move=> ??? [] // ?? [<-] [<-]; eexists. + move=> a b c la lb lc hexp _ hrec s1 s2 heqa [] // v1 vs vs' s1' /=. + t_xrbindP => s1'' hw hws vs2 hexpv vs2' hexpvs <- /=. + have [s2'' hw2 heqa'']:= expand_returnP heqa hexp hw hexpv. + have [s2' hws2 heqa'] := hrec _ _ heqa'' _ _ _ hws hexpvs. + exists s2' => //; apply: cat_fold2 hw2 hws2. +Qed. + End Expr. -Hypothesis Hcomp : expand_prog fi p1 = ok p2. +Hypothesis Hcomp : expand_prog fi entries p1 = ok p2. + +Local Notation ev := tt. + +Section Step1. + +Context step1 + (Hstep1 : map_cfprog_name (expand_fsig fi entries) (p_funcs p1) = ok step1). + +Definition fsigs := + foldr (fun x y => Mf.set y x.1 x.2.2) (Mf.empty _) step1. Lemma eq_globs : p_globs p2 = gd. -Proof. by move: Hcomp; rewrite /expand_prog; t_xrbindP => ?? <-. Qed. +Proof. by move: Hcomp; rewrite /expand_prog; t_xrbindP=> z ??? <-. Qed. Lemma all_checked fn fd1 : get_fundef (p_funcs p1) fn = Some fd1 -> - exists fd2, get_fundef (p_funcs p2) fn = Some fd2 /\ - expand_fd fi fn fd1 = ok fd2. + exists fd2 fd2' m g, [/\ get_fundef (p_funcs p2) fn = Some fd2, + Mf.get fsigs fn = Some g, + expand_fsig fi entries fn fd1 = ok (fd2', m, g) & + expand_fbody fsigs fn (fd2', m) = ok fd2]. Proof. - move: Hcomp; case: p1 => pf1 pg pe. - rewrite /expand_prog; t_xrbindP => /= pf2 hpf2 <- hfd1. - have [fd2 hex hfd2]:= get_map_cfprog_name_gen hpf2 hfd1. - by exists fd2. + move=> /(get_map_cfprog_name_gen Hstep1)[[[fd2' m'] fex'] hex' hfd']. + move: Hcomp; rewrite /expand_prog Hstep1 /=. + t_xrbindP=> pf2 hpf2 ?; subst. + have [f' /= hf' hgf'] := get_map_cfprog_name_gen hpf2 hfd'. + eexists _, _, _, _; split; eauto. + rewrite /fsigs. + elim: step1 hfd' => //= -[] > hrec /=. + by case: ifP => [+[?]|+/hrec]; rewrite eq_sym Mf.setP => ->; subst. Qed. -Local Notation ev := tt. - Let Pi_r s1 (i1:instr_r) s2:= - forall ii m ii' i2 s1', + forall ii m ii' i2 s1', wf_t m -> eq_alloc m s1 s1' -> - expand_i m (MkI ii i1) = ok (MkI ii' i2) -> - exists s2', eq_alloc m s2 s2' /\ sem_i p2 ev s1' i2 s2'. + expand_i fsigs m (MkI ii i1) = ok (MkI ii' i2) -> + exists2 s2', eq_alloc m s2 s2' & sem_i p2 ev s1' i2 s2'. Let Pi s1 (i1:instr) s2:= - forall m i2 s1', + forall m i2 s1', wf_t m -> eq_alloc m s1 s1' -> - expand_i m i1 = ok i2 -> - exists s2', eq_alloc m s2 s2' /\ sem_I p2 ev s1' i2 s2'. + expand_i fsigs m i1 = ok i2 -> + exists2 s2', eq_alloc m s2 s2' & sem_I p2 ev s1' i2 s2'. Let Pc s1 (c1:cmd) s2 := - forall m c2 s1', + forall m c2 s1', wf_t m -> eq_alloc m s1 s1' -> - mapM (expand_i m) c1 = ok c2 -> - exists s2', eq_alloc m s2 s2' /\ sem p2 ev s1' c2 s2'. + mapM (expand_i fsigs m) c1 = ok c2 -> + exists2 s2', eq_alloc m s2 s2' & sem p2 ev s1' c2 s2'. Let Pfor (i1:var_i) vs s1 c1 s2 := - forall m c2 s1', + forall m c2 s1', wf_t m -> eq_alloc m s1 s1' -> Sv.mem i1 m.(svars) -> - mapM (expand_i m) c1 = ok c2 -> - exists s2', eq_alloc m s2 s2' /\ sem_for p2 ev i1 vs s1' c2 s2'. + mapM (expand_i fsigs m) c1 = ok c2 -> + exists2 s2', eq_alloc m s2 s2' & sem_for p2 ev i1 vs s1' c2 s2'. Let Pfun scs m fn vargs scs' m' vres := - sem_call p2 ev scs m fn vargs scs' m' vres. + forall expdin expdout, Mf.get fsigs fn = Some (expdin, expdout) -> + forall vargs', expand_vs expdin vargs = ok vargs' -> + exists2 vres', expand_vs expdout vres = ok vres' & + sem_call p2 ev scs m fn (flatten vargs') scs' m' (flatten vres'). Local Lemma Hskip : sem_Ind_nil Pc. Proof. - move=> s1 m c2 s1' hwf heqa /= [<-]; exists s1'; split => //; constructor. + move=> s1 m c2 s1' hwf heqa /= [<-]; exists s1' => //; constructor. Qed. Local Lemma Hcons : sem_Ind_cons p1 ev Pc Pi. Proof. move=> s1 s2 s3 i c _ Hi _ Hc m c2 s1' hwf heqa1 /=. - t_xrbindP => i' /Hi -/(_ _ hwf heqa1) [s2' [heqa2 hsemi]]. - move=> c' /Hc -/(_ _ hwf heqa2) [s3' [heqa3 hsemc]] <-; exists s3'; split => //. + t_xrbindP => i' /Hi -/(_ _ hwf heqa1) [s2' heqa2 hsemi]. + move=> c' /Hc -/(_ _ hwf heqa2) [s3' heqa3 hsemc] <-; exists s3' => //. econstructor; eauto. Qed. Local Lemma HmkI : sem_Ind_mkI p1 ev Pi_r Pi. Proof. - move=> ii i s1 s2 _ Hi m [ii' i2] s1' hwf heqa /Hi -/(_ _ hwf heqa) [s2' [heqa' hsemi]]. - exists s2'; split => //; constructor. + move=> ii i s1 s2 _ Hi m [ii' i2] s1' hwf heqa /Hi -/(_ _ hwf heqa) [s2' heqa' hsemi]. + exists s2' => //; constructor. Qed. Local Lemma Hassgn : sem_Ind_assgn p1 Pi_r. @@ -353,7 +622,7 @@ Proof. t_xrbindP => x' hx e' he _ <-. have ? := expand_eP hwf heqa he hse. have [s2' [hw' heqa']] := expand_lvP hwf heqa hx hw. - exists s2'; split => //;econstructor; rewrite ?eq_globs; eauto. + exists s2' => //; econstructor; rewrite ?eq_globs; eauto. Qed. Local Lemma Hopn : sem_Ind_opn p1 Pi_r. @@ -362,7 +631,7 @@ Proof. move=> ii m ii' e2 s1' hwf heqa /=; t_xrbindP => xs' hxs es' hes _ <-. have := expand_esP hwf heqa hes hse. have := expand_lvsP hwf heqa hxs hws. - rewrite -eq_globs => -[s2' [hws' ?]] hse'; exists s2'; split => //. + rewrite -eq_globs => -[s2' [hws' ?]] hse'; exists s2' => //. by constructor; rewrite /sem_sopn hse' /= ho. Qed. @@ -373,7 +642,7 @@ Proof. have := expand_esP hwf heqa hes hse. have heqa': eq_alloc m (with_scs (with_mem s1 m2) scs2) (with_scs (with_mem s1' m2) scs2) by case: heqa. have := expand_lvsP hwf heqa' hxs hws. - rewrite -eq_globs => -[s2' [hws' ?]] hse'; exists s2'; split => //. + rewrite -eq_globs => -[s2' [hws' ?]] hse'; exists s2' => //. by econstructor; eauto; rewrite -(eq_alloc_mem heqa) -(eq_alloc_scs heqa). Qed. @@ -382,8 +651,8 @@ Proof. move => s1 s2 e c1 c2 hse hs hrec ii m ii' ? s1' hwf heqa /=. t_xrbindP => e' he c1' hc1 c2' hc2 _ <-. have := expand_eP hwf heqa he hse; rewrite -eq_globs => hse'. - have [s2' [??]] := hrec _ _ _ hwf heqa hc1. - by exists s2'; split => //; apply Eif_true. + have [s2' ??] := hrec _ _ _ hwf heqa hc1. + by exists s2' => //; apply Eif_true. Qed. Local Lemma Hif_false : sem_Ind_if_false p1 ev Pc Pi_r. @@ -391,29 +660,29 @@ Proof. move => s1 s2 e c1 c2 hse hs hrec ii m ii' ? s1' hwf heqa /=. t_xrbindP => e' he c1' hc1 c2' hc2 _ <-. have := expand_eP hwf heqa he hse; rewrite -eq_globs => hse'. - have [s2' [??]] := hrec _ _ _ hwf heqa hc2. - by exists s2'; split => //; apply Eif_false. + have [s2' ??] := hrec _ _ _ hwf heqa hc2. + by exists s2' => //; apply Eif_false. Qed. Local Lemma Hwhile_true : sem_Ind_while_true p1 ev Pc Pi_r. Proof. move => s1 s2 s3 s4 a c1 e c2 _ hrec1 hse _ hrec2 _ hrecw ii m ii' ? s1' hwf heqa /=. t_xrbindP => e' he c1' hc1 c2' hc2 hii <-. - have [sc1 [heqa1 hs1]]:= hrec1 _ _ _ hwf heqa hc1. + have [sc1 heqa1 hs1]:= hrec1 _ _ _ hwf heqa hc1. have := expand_eP hwf heqa1 he hse; rewrite -eq_globs => hse'. - have [sc2 [heqa2 hs2]]:= hrec2 _ _ _ hwf heqa1 hc2. - have [| s2' [? hsw]]:= hrecw ii m ii' (Cwhile a c1' e' c2') _ hwf heqa2. + have [sc2 heqa2 hs2]:= hrec2 _ _ _ hwf heqa1 hc2. + have [| s2' ? hsw]:= hrecw ii m ii' (Cwhile a c1' e' c2') _ hwf heqa2. + by rewrite /= he hc1 hc2 hii. - exists s2'; split => //; apply: Ewhile_true hsw; eauto. + exists s2' => //; apply: Ewhile_true hsw; eauto. Qed. Local Lemma Hwhile_false : sem_Ind_while_false p1 ev Pc Pi_r. Proof. move => s1 s2 a c e c' _ hrec1 hse ii m ii' ? s1' hwf heqa /=. t_xrbindP => e' he c1' hc1 c2' hc2 hii <-. - have [s2' [heqa1 hs1]]:= hrec1 _ _ _ hwf heqa hc1. + have [s2' heqa1 hs1]:= hrec1 _ _ _ hwf heqa hc1. have := expand_eP hwf heqa1 he hse; rewrite -eq_globs => hse'. - exists s2'; split => //; apply: Ewhile_false; eauto. + exists s2' => //; apply: Ewhile_false; eauto. Qed. Local Lemma Hfor : sem_Ind_for p1 ev Pi_r Pfor. @@ -422,46 +691,48 @@ Proof. t_xrbindP => hin lo' hlo hi' hhi c' hc ? <-. have := expand_eP hwf heqa hlo hslo. have := expand_eP hwf heqa hhi hshi; rewrite -eq_globs => hshi' hslo'. - have [s2' [??]]:= hfor _ _ _ hwf heqa hin hc. - exists s2'; split => //; econstructor; eauto. + have [s2' ??]:= hfor _ _ _ hwf heqa hin hc. + exists s2' => //; econstructor; eauto. Qed. Local Lemma Hfor_nil : sem_Ind_for_nil Pfor. Proof. - move=> s i c i2 c' s1' hwf heqa _; exists s1'; split => //; constructor. + move=> s i c i2 c' s1' hwf heqa _; exists s1' => //; constructor. Qed. Local Lemma Hfor_cons : sem_Ind_for_cons p1 ev Pc Pfor. Proof. move=> s1 s1w s2 s3 i w ws c Hwi _ Hc _ Hfor m c' s1' hwf heqa hin hc. have [s1w' [? heqa1']]:= eq_alloc_write_var hwf heqa hin Hwi. - have [s2' [heqa2 ?]]:= Hc _ _ _ hwf heqa1' hc. - have [s3' [??]]:= Hfor _ _ _ hwf heqa2 hin hc. - exists s3'; split => //; econstructor; eauto. + have [s2' heqa2 ?]:= Hc _ _ _ hwf heqa1' hc. + have [s3' ??]:= Hfor _ _ _ hwf heqa2 hin hc. + exists s3' => //; econstructor; eauto. Qed. Local Lemma Hcall : sem_Ind_call p1 ev Pi_r Pfun. Proof. - move=> s1 scs2 m2 s2 ii xs fn args vargs vs Hes Hsc Hfun Hw ii1 m ii2 i2 s1' hwf heqa /=. - t_xrbindP => xs' hxs es' hes ? <-. - have := expand_esP hwf heqa hes Hes. + move=> s1 scs2 m2 s2 ii xs fn args vargs vs Hes Hsc Hfun Hw ii1 m ii2 i2 s1' hwf heqa /=. + case hgfn: Mf.get => [[ei eo]|//]. + t_xrbindP=> xs' sxs' hxs <- es' ses' hes <- _. + have [? heva]:= expand_paramsP hwf heqa hes Hes. have heqa': eq_alloc m (with_scs (with_mem s1 m2) scs2) (with_scs (with_mem s1' m2) scs2) by case: heqa. - have [s2' []]:= expand_lvsP hwf heqa' hxs Hw. - rewrite -eq_globs => ???; exists s2'; split => //; econstructor; eauto. + case: {Hfun}(Hfun ei eo hgfn _ heva) => ? hevr. + have [s2' ]:= expand_returnsP hwf heqa' hxs Hw hevr. + rewrite -eq_globs => ???? <-; exists s2' => //; econstructor; eauto. by case: heqa => _ <- <-. Qed. -Lemma wf_init_map ffi m : init_map ffi = ok m -> wf_t m. +Lemma wf_init_map ffi m finf : init_map ffi = ok (m, finf) -> wf_t m. Proof. rewrite /init_map; t_xrbindP. - set svars_ := of_list _. + set svars_ := sv_of_list _ _. pose wf_st := fun (svm: Sv.t * Mvar.t array_info) => [/\ wf_t {| svars := svars_; sarrs := svm.2 |}, Sv.Subset svars_ svm.1 & - (forall x ai i xi, + (forall x ai xi, Mvar.get svm.2 x = Some ai -> - Mi.get (ai_elems ai) i = Some xi -> + xi \in (ai_elems ai) -> Sv.In xi svm.1)]. suff : forall l svm svm', wf_st svm -> foldM init_array_info svm l = ok svm' -> wf_st svm'. + move=> h svm' /h []; first by split => //=. @@ -469,104 +740,179 @@ Proof. elim => /= [ ??? [<-] // | vi vis hrec svm svm' hwf]. t_xrbindP => svm1 heq; apply: hrec. move: heq; rewrite /init_array_info. - case: svm hwf => sv1 m1 hwf; t_xrbindP => /Sv_memP hin [[sv2 m2] b]. - set ty := sword _. - pose wf_sm := - fun (svmp : Sv.t * Mi.t var * Z) => - let '(sv,mi,_) := svmp in - Sv.Subset sv1 sv /\ - (forall i xi, Mi.get mi i = Some xi -> - [/\ ~Sv.In xi sv1, Sv.In xi sv, - vtype xi == ty & - forall j xj, i <> j -> Mi.get mi j = Some xj -> xi <> xj]). - suff : forall ids svmp svmp', - wf_sm svmp -> - foldM (init_elems ty) svmp ids = ok svmp' -> wf_sm svmp'. - + move=> h /h{h}h [<-]. - have /h{h}[hsub hmi] : wf_sm (sv1, Mi.empty var, 0%Z) by split. - case: hwf => hwf hsub' hget; split => //. - + move=> x ai /=; rewrite Mvar.setP; case: eqP. - + move=> <- [<-]; split. - + by apply/negP/Sv_memP; SvD.fsetdec. - move=> i xi /= hgeti; have [/= hnin heqt hj] := hmi _ _ hgeti; split. - + by apply/negP/Sv_memP; SvD.fsetdec. - split => // x' ai' i' xi'. - rewrite Mvar.setP; case: eqP => [<- [<-] /= hgeti' hd| hne]. - + by case: (hmi _ _ hgeti) => ??? h; apply/eqP/(h i') => //; case: hd. - move=> h1 h2 ?; have /= ?:= hget _ _ _ _ h1 h2; apply /eqP => heq. - by apply hnin; rewrite heq. - move=> /eqP hne /dup[] hgetx /hwf /= [? hgeti]; split => //. - move=> i xi /dup[] hi /hgeti [?] [? h]; split => //; split => //. - move=> x' ai' i' xi'; rewrite Mvar.setP; case: eqP. - + move=> ? [<-]; subst x' => /= hi' ?. - have /= ? := hget _ _ _ _ hgetx hi. - by have [hnin ???]:= hmi _ _ hi'; apply/eqP => heq; apply hnin; rewrite -heq. - by move=> ? hgetx'; have [? /(_ _ _ hi) [?] [?] /= ]:= hwf _ _ hgetx; apply. - + by rewrite /=; SvD.fsetdec. - move=> /= x ai i xi; rewrite Mvar.setP; case: eqP. - + by move=> ? [<-]; subst x => /hmi []. - move=> ? h1 h2; have /= := hget _ _ _ _ h1 h2; SvD.fsetdec. - elim => /= [???[<-] // | id ids hrec] [[sv mi] i] svmp' hwfsm. - t_xrbindP => svmp'' hsvmp''; apply hrec; move: hsvmp''. - rewrite /init_elems; t_xrbindP => /Sv_memP hnin <-. - case: hwfsm => h1 h2; split; first by SvD.fsetdec. - move=> i1 xi1; rewrite Mi.setP; case: eqP => ?. - + subst i1 => -[<-]; split => //; try SvD.fsetdec. - move=> j xj hji; rewrite Mi.setP_neq; last by apply/eqP. - by move=> /h2 [] hj1 hj2 _ _ heq; apply hnin; rewrite heq. - move=> /h2 [] hi1 hi2 hi3 hi4; split => //; first by SvD.fsetdec. - move=> j xj ji; rewrite Mi.setP; case: eqP => _; last by apply hi4. - by move=> [<-] heq; apply hnin; rewrite -heq. + case: svm hwf => sv1 m1 hwf; t_xrbindP => /Sv_memP hin [sv2 len]. + set ty := sword _; t_xrbindP. + set elems := [seq _ | id <- vi_n vi] => hfold. + have : + [/\ Sv.Equal sv2 (Sv.union (sv_of_list id elems) sv1), + disjoint sv1 (sv_of_list (fun x => x) elems), + uniq elems & + len = (0 + Z.of_nat (size elems))%Z]. + + elim: elems sv1 {hwf hin} 0%Z hfold => /= [ | x elems hrec] sv1 z; t_xrbindP. + + move => <- <-; split => //; last by rewrite Z.add_0_r. + by rewrite /sv_of_list /=; apply/disjointP; SvD.fsetdec. + move=> _ /Sv_memP hnin <- /hrec [heq /disjointP hdis huni ->]; split => //. + + by rewrite sv_of_list_cons heq; SvD.fsetdec. + + apply/disjointP => y ?; rewrite sv_of_list_cons. + by have := hdis y; SvD.fsetdec. + + apply /andP; split => //; apply /negP => hin. + by apply (hdis x); [SvD.fsetdec | apply /sv_of_listP/map_f]. + have /= -> := Nat2Z.inj_succ (size elems); ring. + move=> [heq /disjointP hdis huni hlen] /andP [] /ZltP h0len /eqP hty <-. + case: hwf => /= hwf hincl hget. + split => /=. + + move=> x ai /=; rewrite Mvar.setP; case: eqP. + + move=> ? [<-]; subst x. + constructor => //=. + + by have := hdis (vi_v vi); SvD.fsetdec. + + by move=> xi; rewrite -(map_id elems) => /sv_of_listP; have := hdis xi; SvD.fsetdec. + + by move=> xi /mapP [id ? ->]. + move=> x' ai' xi /eqP ?. rewrite Mvar.setP_neq // => /hget -/(_ xi) h []. + by rewrite -(map_id elems) => /sv_of_listP -/hdis h1 /h. + move=> hne /dup[] /hget h1 /hwf [/= ??????? xi_disj]; constructor => //=. + move=> x' ai' xi hxx'; rewrite Mvar.setP; case: eqP => [? | hne']; last by apply xi_disj. + by move=> [<-] [] /= /h1 /hdis h2; rewrite -(map_id elems) => /sv_of_listP. + + by SvD.fsetdec. + move=> x ai xi; rewrite Mvar.setP; case: eqP => [? | _]. + + by move=> [<-] /=; rewrite -(map_id elems) => /sv_of_listP; SvD.fsetdec. + move=> h1 h2; have := hget _ _ _ h1 h2; SvD.fsetdec. +Qed. + +Lemma eq_alloc_empty m scs mem : + wf_t m -> + eq_alloc m {| escs := scs; emem := mem; evm := Vm.init |} {| escs := scs; emem := mem; evm := Vm.init |}. +Proof. + move=> hwf; split => //; split => //=. + move=> x ai xi /hwf hva hin. + rewrite !Vm.initP (x_ty hva) (xi_ty hva hin) /=. + case heq : WArray.get => [w | /=]; last first. + + by rewrite /undef_v (undef_x_vundef (_ _)). + have []:= WArray.get_bound heq; rewrite /mk_scale => ???. + have h : ((0 <= 0%N)%Z ∧ (0%N < wsize_size (ai_ty ai)))%Z. + + by move=> /=; have := wsize_size_pos (ai_ty ai); Psatz.lia. + have [_ /(_ 0 h)] := read_read8 heq. + by rewrite WArray.get0 //= WArray.addE; have := wsize_size_pos (ai_ty ai); Psatz.lia. +Qed. + +Lemma mapM2_dc_truncate_id tys vs vs': + mapM2 ErrType dc_truncate_val tys vs' = ok vs -> vs' = vs. +Proof. + by rewrite /dc_truncate_val /=; move=> h; have := mapM2_Forall3 h; elim => // _ > [->] _ ->. +Qed. + +Lemma expend_tyv_expand_return m b tys (xs : list var_i) ins: + mapM2 E.length_mismatch (expand_tyv m b) tys xs = ok ins -> + mapM2 E.length_mismatch (expand_return m) [seq i.2 | i <- ins] [seq Lvar i | i <- xs] = + ok [seq map Lvar x.1.2 | x <- ins]. +Proof. + move=> hxs; have := mapM2_Forall3 hxs; elim => //= {tys hxs xs ins}. + move=> ty x [[tysx xsx] o] tys xs cs0 hexty _ hrec; move: hexty. + rewrite {1}/expand_tyv {2}/expand_return /=. + case heq : Mvar.get => [ai | ]; t_xrbindP. + + by move=> _ ???; subst tysx xsx o; rewrite /= !eqxx hrec /= map_comp. + by move=> hin ???; subst tysx xsx o; rewrite hin /= hrec. +Qed. + +Lemma expend_tyv_expand_param m b tys (xs : list var_i) ins: + mapM2 E.length_mismatch (expand_tyv m b) tys xs = ok ins -> + mapM2 E.length_mismatch (expand_param m) [seq i.2 | i <- ins] [seq Pvar (mk_lvar i) | i <- xs] = + ok [seq map (fun y => Pvar (mk_lvar y)) x.1.2 | x <- ins]. +Proof. + move=> hxs; have := mapM2_Forall3 hxs; elim => //= {tys hxs xs ins}. + move=> ty x [[tysx xsx] o] tys xs cs0 hexty _ hrec; move: hexty. + rewrite {1}/expand_tyv {2}/expand_param /=. + case heq : Mvar.get => [ai | ]; t_xrbindP. + + by move=> _ ???; subst tysx xsx o; rewrite /= !eqxx /= hrec /= -!map_comp. + by move=> hin ???; subst tysx xsx o; rewrite /check_gvar /=hin /= hrec. Qed. Local Lemma Hproc : sem_Ind_proc p1 ev Pc Pfun. Proof. move=> scs1 m1 scs2 m2 fn f vargs vargs' s0 s1 s2 vres vres' Hget Hca [?] Hw _ Hc Hres Hcr ??; subst s0 scs2 m2. - have [fd2 [Hget2 /=] {Hget}]:= all_checked Hget. - rewrite /expand_fd; t_xrbindP=> m. + have [fd1 [fd2 [m [inout [Hget2 hsigs /=]]]] {Hget}]:= all_checked Hget. + rewrite /expand_fsig; t_xrbindP => -[mt finf]. case: f Hca Hw Hc Hres Hcr => /=. move=> finfo ftyin fparams fbody ftyout fres fextra. set fd := {| f_info := finfo |} => Hca Hw Hc Hres Hcr hinit. - t_xrbindP => hparams hres body' hbody hfd2; rewrite /Pfun. + t_xrbindP => ins hparams outs hres <- ??; subst mt inout. + t_xrbindP => c hc ?; subst fd1. + move=> expdin expdout; rewrite hsigs => -[??] vargs1 hexvs; subst expdin expdout. + set (sempty := {| escs := scs1; emem := m1; evm := Vm.init |}). have hwf := wf_init_map hinit. - have heqa : eq_alloc m {| escs := scs1; emem := m1; evm := vmap0 |} {| escs := scs1; emem := m1; evm := vmap0 |}. - + split => //; split => //. - move=> x ai i xi hai hxi. - rewrite /eval_array /= /get_var !Fv.get0. - have [_ /(_ _ _ hxi) [_] []/eqP -> _ /=]:= hwf _ _ hai. - case: (vtype x) => //= p. - case heq : (WArray.get AAscale (ai_ty ai) (WArray.empty p) i) => [w | ] //=. - have []:= WArray.get_bound heq; rewrite /mk_scale => ???. - have h : ((0 <= 0%N)%Z ∧ (0%N < wsize_size (ai_ty ai)))%Z. - + by move=> /=; have := wsize_size_pos (ai_ty ai); Psatz.lia. - have [_ /(_ 0 h)] := read_read8 heq. - by rewrite WArray.get0 //= WArray.addE; have := wsize_size_pos (ai_ty ai); Psatz.lia. - have [s1' [hparams' heqa1]] := eq_alloc_write_vars hwf heqa hparams Hw. - have [s2' [heqa2 hsem]]:= Hc _ _ _ hwf heqa1 hbody. - rewrite (check_var_gets hres heqa2) in Hres. - by subst fd2; econstructor => /=; eauto; case: heqa2. + have heqae : eq_alloc m sempty sempty by apply eq_alloc_empty. + rewrite (write_vars_lvals false gd) in Hw. + have [??]:= (mapM2_dc_truncate_id Hca, mapM2_dc_truncate_id Hcr); subst vargs' vres'. + have [s1']:= expand_returnsP hwf heqae (expend_tyv_expand_return hparams) Hw hexvs. + rewrite map_comp -map_flatten -(write_vars_lvals false gd) => hw heqa1. + have [s2' heqa2 hsem]:= Hc _ _ _ hwf heqa1 hc. + rewrite -(sem_pexprs_get_var false gd) in Hres. + have [vs' hex]:= expand_paramsP hwf heqa2 (expend_tyv_expand_param hres) Hres. + rewrite map_comp -map_flatten sem_pexprs_get_var => hwr. + exists vs' => //. + econstructor; eauto => //=. + + elim: (mapM2_Forall3 hparams) vargs vargs1 {Hw Hca hw} hexvs. + + by move=> [] //= ? [<-]. + move=> ty x [[tysx xsx] o] tys xs cs0 hexty _ hrec [] //= v vs ?. + t_xrbindP => ? hexp ? hexps <- /=; apply: cat_mapM2 (hrec _ _ hexps). + move: hexty hexp; rewrite /expand_tyv /expand_v. + case heq: Mvar.get => [ai | ]; t_xrbindP. + + move=> _ ???; subst tysx xsx o. + have hva := hwf _ _ heq. + rewrite (wf_ai_elems (v_var x) hva) -map_comp /comp. + by move=> /mapM_Forall2; elim => //= > _ _ ->. + by move=> hin <- _ <- [<-]. + + elim: (mapM2_Forall3 hres) vres vs' {hwr Hcr Hres} hex. + + by move=> [] //= ? [<-]. + move=> ty x [[tysx xsx] o] tys xs cs0 hexty _ hrec [] //= v vs ?. + t_xrbindP => ? hexp ? hexps <- /=; apply: cat_mapM2 (hrec _ _ hexps). + move: hexty hexp; rewrite /expand_tyv /expand_v. + case heq: Mvar.get => [ai | ]; t_xrbindP. + + move=> _ ???; subst tysx xsx o. + have hva := hwf _ _ heq. + rewrite (wf_ai_elems (v_var x) hva) -map_comp /comp. + by move=> /mapM_Forall2; elim => //= > _ _ ->. + by move=> hin <- _ <- [<-]. + + by case: heqa2. + by case: heqa2. Qed. +Lemma expand_callP_aux f scs mem scs' mem' va vr: + sem_call p1 ev scs mem f va scs' mem' vr -> + Pfun scs mem f va scs' mem' vr. +Proof. + exact: (sem_call_Ind Hskip Hcons HmkI Hassgn Hopn Hsyscall + Hif_true Hif_false Hwhile_true Hwhile_false Hfor Hfor_nil Hfor_cons Hcall Hproc). +Qed. + +End Step1. + Lemma expand_callP f scs mem scs' mem' va vr: - sem_call p1 ev scs mem f va scs' mem' vr -> sem_call p2 ev scs mem f va scs' mem' vr. -Proof. - exact: - (sem_call_Ind - Hskip - Hcons - HmkI - Hassgn - Hopn - Hsyscall - Hif_true - Hif_false - Hwhile_true - Hwhile_false - Hfor - Hfor_nil - Hfor_cons - Hcall - Hproc). + sem_call p1 ev scs mem f va scs' mem' vr -> + f \in entries -> + sem_call p2 ev scs mem f va scs' mem' vr. +Proof. + apply: (rbindP _ Hcomp) => s1 /[dup]Hs1/expand_callP_aux h _ /[dup]+/h{h}. + move=> [???? {}f fd {}va va' ??? {}vr vr' hgf htri _ _ _ _ htro _ _] h b. + suff /h{h}h : Mf.get (fsigs s1) f = + Some (map (fun=> None) (f_tyin fd), map (fun=> None) (f_tyout fd)). + + have /h{h}[?] : + expand_vs (map (fun=> None) (f_tyin fd)) va' = ok [seq [:: x] | x <- va']. + + by elim: (f_tyin fd) va' va htri {h} => [[]|> hrec []]//=; t_xrbindP=> > /hrec ->. + have : expand_vs (map (fun=> None) (f_tyout fd)) vr' = ok [seq [:: x] | x <- vr']. + + by elim: (f_tyout fd) vr vr' htro => [[]//?[<-]//|> hrec [] //=>]; t_xrbindP => ? /hrec + <- => ->. + by move=> -> [<-]; rewrite 2!flatten_seq1. + move: Hs1 fd hgf {h htri htro}; rewrite {}/fsigs; elim: (p_funcs p1) s1 + => [> [<-]|[?[? fti fp ? fto fr]]> hrec] //=. + t_xrbindP=> > +?? /hrec{hrec}h ?; subst=> /=. + case: eqP; last by move=> /nesym /eqP?; rewrite Mf.setP_neq //. + move=> <- + ? [] <- /=. + rewrite Mf.setP_eq /expand_fsig b /=; t_xrbindP=> -[??] _; t_xrbindP=> ? hz ? hz1 <- /=. + do 2 f_equal. + + move: (mapM2_Forall3 hz); elim => //= > + _ ->. + by rewrite /expand_tyv; case: Mvar.get => //; t_xrbindP => _ <-. + move: (mapM2_Forall3 hz1); elim => //= > + _ ->. + by rewrite /expand_tyv; case: Mvar.get => //; t_xrbindP => _ <-. Qed. End WITH_PARAMS. + diff --git a/proofs/compiler/array_init.v b/proofs/compiler/array_init.v index 2be46b69d..70f36df72 100644 --- a/proofs/compiler/array_init.v +++ b/proofs/compiler/array_init.v @@ -7,7 +7,6 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope vmap. Local Open Scope seq_scope. Section ASM_OP. diff --git a/proofs/compiler/array_init_proof.v b/proofs/compiler/array_init_proof.v index 3e02e5a55..d9da32b70 100644 --- a/proofs/compiler/array_init_proof.v +++ b/proofs/compiler/array_init_proof.v @@ -8,12 +8,13 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope vmap. Local Open Scope seq_scope. Section WITH_PARAMS. Context + {wsw : WithSubWord} + {dc:DirectCall} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} @@ -21,7 +22,7 @@ Context Section Section. -Context {T:eqType} {pT:progT T} {sCP: semCallParams} (wf_init: wf_init sCP). +Context {T:eqType} {pT:progT T} {sCP: semCallParams}. Section REMOVE_INIT. @@ -32,29 +33,26 @@ Section REMOVE_INIT. Let Pi s1 (i:instr) s2 := forall vm1, - vm_uincl (evm s1) vm1 -> wf_vm vm1 -> - exists vm2, - [/\ sem p' ev (with_vm s1 vm1) (remove_init_i is_reg_array i) (with_vm s2 vm2), - vm_uincl (evm s2) vm2 & - wf_vm vm2]. + evm s1 <=1 vm1 -> + exists2 vm2, + sem p' ev (with_vm s1 vm1) (remove_init_i is_reg_array i) (with_vm s2 vm2) & + evm s2 <=1 vm2. Let Pi_r s1 (i:instr_r) s2 := forall ii, Pi s1 (MkI ii i) s2. Let Pc s1 (c:cmd) s2 := forall vm1, - vm_uincl (evm s1) vm1 -> wf_vm vm1 -> - exists vm2, - [/\ sem p' ev (with_vm s1 vm1) (remove_init_c is_reg_array c) (with_vm s2 vm2), - vm_uincl (evm s2) vm2 & - wf_vm vm2]. + evm s1 <=1 vm1 -> + exists2 vm2, + sem p' ev (with_vm s1 vm1) (remove_init_c is_reg_array c) (with_vm s2 vm2) & + evm s2 <=1 vm2. Let Pfor (i:var_i) vs s1 c s2 := forall vm1, - vm_uincl (evm s1) vm1 -> wf_vm vm1 -> - exists vm2, - [/\ sem_for p' ev i vs (with_vm s1 vm1) (remove_init_c is_reg_array c) (with_vm s2 vm2), - vm_uincl (evm s2) vm2 & - wf_vm vm2]. + evm s1 <=1 vm1 -> + exists2 vm2, + sem_for p' ev i vs (with_vm s1 vm1) (remove_init_c is_reg_array c) (with_vm s2 vm2) & + evm s2 <=1 vm2. Let Pfun scs m fn vargs scs' m' vres := forall vargs', @@ -63,78 +61,61 @@ Section REMOVE_INIT. List.Forall2 value_uincl vres vres'. Local Lemma Rnil : sem_Ind_nil Pc. - Proof. by move=> s vm1 Hvm1;exists vm1;split=> //;constructor. Qed. + Proof. by move=> s vm1 Hvm1;exists vm1 => //;constructor. Qed. Local Lemma Rcons : sem_Ind_cons p ev Pc Pi. Proof. - move=> s1 s2 s3 i c _ Hi _ Hc vm1 Hvm1 /(Hi _ Hvm1) [vm2 []] Hsi Hvm2 /(Hc _ Hvm2) [vm3 []] Hsc ??. - by exists vm3;split=>//=; apply: sem_app Hsc. + move=> s1 s2 s3 i c _ Hi _ Hc vm1 /(Hi _) [vm2 Hsi] /(Hc _) [vm3] Hsc ?. + by exists vm3 =>//=; apply: sem_app Hsc. Qed. Local Lemma RmkI : sem_Ind_mkI p ev Pi_r Pi. - Proof. by move=> ii i s1 s2 _ Hi vm1 Hvm1 /(Hi ii _ Hvm1) [vm2 []] Hsi ??;exists vm2. Qed. + Proof. by move=> ii i s1 s2 _ Hi vm1 /(Hi ii) [vm2] ??;exists vm2. Qed. Lemma is_array_initP e : is_array_init e -> exists n, e = Parr_init n. Proof. by case: e => // n _; eauto. Qed. Lemma assgn_uincl s1 s2 e v ty v' vm1 x ii tag: - sem_pexpr gd s1 e = ok v -> + sem_pexpr true gd s1 e = ok v -> truncate_val ty v = ok v' -> - write_lval gd x v' s1 = ok s2 -> - vm_uincl (evm s1) vm1 -> - wf_vm vm1 -> - ∃ vm2 : vmap, - [/\ sem p' ev (with_vm s1 vm1) [:: MkI ii (Cassgn x tag ty e)] (with_vm s2 vm2), - vm_uincl (evm s2) vm2 & - wf_vm vm2]. + write_lval true gd x v' s1 = ok s2 -> + evm s1 <=1 vm1 -> + exists2 vm2 : Vm.t, + sem p' ev (with_vm s1 vm1) [:: MkI ii (Cassgn x tag ty e)] (with_vm s2 vm2) & + evm s2 <=1 vm2. Proof. move=> Hse hsub hwr Hvm1. have [z' Hz' Hz] := sem_pexpr_uincl Hvm1 Hse. have [z1 htr Uz1]:= value_uincl_truncate Hz hsub. - move=> hwf ; have [vm2 Hw ?]:= write_uincl Hvm1 Uz1 hwr. - exists vm2;split=> //. - + apply sem_seq1;constructor;econstructor;eauto. - by apply: wf_write_lval Hw. + have [vm2 Hw ?]:= write_uincl Hvm1 Uz1 hwr. + exists vm2 => //; apply sem_seq1;constructor;econstructor;eauto. Qed. Local Lemma Rasgn : sem_Ind_assgn p Pi_r. Proof. - move=> s1 s2 x tag ty e v v' Hse hsub hwr ii vm1 Hvm1 /=; case: ifP; last first. - + by move=> _; apply: assgn_uincl Hse hsub hwr Hvm1. + move=> s1 s2 x tag ty e v v' Hse hsub hwr ii vm1 /=; case: ifP; last first. + + by move=> _; apply: assgn_uincl Hse hsub hwr. case: ifP; last first. - + by move=> _ _; apply: assgn_uincl Hse hsub hwr Hvm1. + + by move=> _ _; apply: assgn_uincl Hse hsub hwr. move=> _ /is_array_initP [n e1];subst e. case: Hse => ?; subst v. move: hsub;rewrite /truncate_val;case: ty => //= nty. t_xrbindP => empty /WArray.cast_empty_ok ??; subst v' empty. - case: x hwr => [vi t | [[xt xn] xi] | ws x e | aa ws x e | aa ws len [[xt xn] xi] e] /=. - + by move=> /write_noneP [->];exists vm1;split=> //;constructor. - + apply: rbindP => vm1';apply: on_vuP => //=. - + case: xt => //= p0 _ /WArray.cast_empty_ok -> ? [?]; subst => Wf1. - exists vm1;split => //=; first by constructor. - move=> z;have := Hvm1 z. - case: ({| vtype := sarr p0; vname := xn |} =P z) => [<- _ | /eqP neq]. - + rewrite Fv.setP_eq; have := Wf1 {| vtype := sarr p0; vname := xn |}. - case: (vm1.[_]) => //= [ | [] //]. - move=> a _;split => //. - move=> ??; rewrite (WArray.get_empty); case: ifP => //. - by rewrite Fv.setP_neq. - by rewrite /of_val;case:xt => //= ? ?; case: wsize_eq_dec => // ?; case: CEDecStype.pos_dec. + case: x hwr => [vi t | [x xi] | ws x e | aa ws x e | aa ws len [x xi] e] /=. + + by move=> /write_noneP [->];exists vm1 => //;constructor. + + move=> /write_varP_arr [/=hty _ _ ->] /= hsub. + exists vm1; first by constructor. + apply vm_uincl_set_l => //=. + have /compat_valEl := Vm.getP vm1 x; rewrite -hty eqxx => -[t' ->]. + by apply: WArray.uincl_empty. + by t_xrbindP. + by apply: on_arr_varP => ???; t_xrbindP. apply: on_arr_varP => /= tlen t ?; t_xrbindP => hg i vi hvi hi _ /WArray.cast_empty_ok ->. - move => t1 ht1; apply: rbindP => vm1' hset [<-] Wf1; subst xt. - exists vm1;split => //=; first by constructor. - move=> z;have := Hvm1 z. - move: hset; apply: set_varP => //= ? <- <-. - case: ({| vtype := sarr tlen; vname := xn |} =P z) => [<- _ | /eqP neq]; last by rewrite Fv.setP_neq. - rewrite Fv.setP_eq; have := Wf1 {| vtype := sarr tlen; vname := xn |}. - move: hg; rewrite /get_var /on_vu /=. set x := {| vtype := _|}. - have := Hvm1 x; rewrite /eval_uincl. - case: (evm s1).[x] => [ a1 | [] //]. - case: vm1.[x] => [a2 | //] [ _ hu] heq _. - have ?:= Varr_inj1 (ok_inj heq); subst a1 => {heq}. - rewrite WArray.castK. + move => t1 ht1 /write_varP_arr [/= hty _ _ ->] hsub. + exists vm1; first by constructor. + apply vm_uincl_set_l => //=. + move: hg; rewrite /get_var; t_xrbindP => _ hx. + have := hsub x; rewrite hx -hty eqxx => /value_uinclE [t2 -> hu]. split => //. move=> k w; rewrite (WArray.set_sub_get8 ht1) /=; case: ifP => ?. + by rewrite WArray.get_empty; case: ifP. @@ -146,98 +127,91 @@ Section REMOVE_INIT. move=> s1 s2 t o xs es H ii vm1 Hvm1; move: H;rewrite /sem_sopn; t_xrbindP => rs vs. move=> /(sem_pexprs_uincl Hvm1) [] vs' H1 H2. move=> /(vuincl_exec_opn H2) [] rs' H3 H4. - move=> /(writes_uincl Hvm1 H4) [] vm2 Hw ?. - exists vm2;split => //=;last by apply: wf_write_lvals Hw. + move=> /(writes_uincl Hvm1 H4) [] vm2 Hw ?; exists vm2 => //. by apply sem_seq1;constructor;constructor;rewrite /sem_sopn H1 /= H3. Qed. Local Lemma Rsyscall : sem_Ind_syscall p Pi_r. Proof. - move=> s1 scs m s2 o xs es ves vs he hsys hw ii vm1 uvm hwf. + move=> s1 scs m s2 o xs es ves vs he hsys hw ii vm1 uvm. have [ves' he' uves] := sem_pexprs_uincl uvm he. have [vs' hsys' uvs]:= exec_syscallP hsys uves. have [vm2 hw'] := writes_uincl (s1 := with_scs (with_mem s1 m) scs) uvm uvs hw. - exists vm2;split => //=;last by apply: wf_write_lvals hw'. - apply sem_seq1; constructor; econstructor; eauto. + exists vm2 => //=; apply sem_seq1; constructor; econstructor; eauto. Qed. Local Lemma Rif_true : sem_Ind_if_true p ev Pc Pi_r. Proof. move=> s1 s2 e c1 c2 H _ Hc ii vm1 Hvm1. - have [v' H1 /value_uinclE ?] := sem_pexpr_uincl Hvm1 H;subst => Hwf. - have [vm2 [??]]:= Hc _ Hvm1 Hwf;exists vm2;split=>//. - by apply sem_seq1;constructor;apply Eif_true;rewrite // H1. + have [v' H1 /value_uinclE ?] := sem_pexpr_uincl Hvm1 H; subst. + have [vm2 ??]:= Hc _ Hvm1; exists vm2 => //. + by apply sem_seq1; constructor; apply Eif_true; rewrite // H1. Qed. Local Lemma Rif_false : sem_Ind_if_false p ev Pc Pi_r. Proof. move=> s1 s2 e c1 c2 H _ Hc ii vm1 Hvm1. - have [v' H1 /value_uinclE ?] := sem_pexpr_uincl Hvm1 H;subst => Hwf. - have [vm2 [??]]:= Hc _ Hvm1 Hwf;exists vm2;split=>//. + have [v' H1 /value_uinclE ?] := sem_pexpr_uincl Hvm1 H;subst. + have [vm2 ??]:= Hc _ Hvm1; exists vm2 => //. by apply sem_seq1;constructor;apply Eif_false;rewrite // H1. Qed. Local Lemma Rwhile_true : sem_Ind_while_true p ev Pc Pi_r. Proof. - move=> s1 s2 s3 s4 a c e c' _ Hc H _ Hc' _ Hw ii vm1 Hvm1 Hwf;move: H. - have [vm2 [Hs2 Hvm2 Hwf2]] := Hc _ Hvm1 Hwf. - move=> /(sem_pexpr_uincl Hvm2) [] v' H1 /value_uinclE H2;subst. - have [vm3 [H4 Hvm3 ]]:= Hc' _ Hvm2 Hwf2. - move=> /(Hw ii _ Hvm3) [vm4 [Hsem ??]]; exists vm4;split => //=. + move=> s1 s2 s3 s4 a c e c' _ Hc + _ Hc' _ Hw ii vm1 Hvm1. + have [vm2 Hs2 Hvm2] := Hc _ Hvm1. + move=> /(sem_pexpr_uincl Hvm2) [] v' H1 /value_uinclE H2; subst. + have [vm3 H4 Hvm3]:= Hc' _ Hvm2. + have [vm4 Hsem ?] := Hw ii _ Hvm3; exists vm4 => //=. apply sem_seq1;constructor;eapply Ewhile_true;eauto. by case/semE: Hsem => si [] /sem_IE ? /semE ?; subst si. Qed. Local Lemma Rwhile_false : sem_Ind_while_false p ev Pc Pi_r. Proof. - move=> s1 s2 a c e c' _ Hc H ii vm1 Hvm1 Hwf; move: H. - have [vm2 [Hs2 Hvm2 Hwf2]] := Hc _ Hvm1 Hwf. + move=> s1 s2 a c e c' _ Hc H ii vm1 Hvm1; move: H. + have [vm2 Hs2 Hvm2] := Hc _ Hvm1. move=> /(sem_pexpr_uincl Hvm2) [] v' H1 /value_uinclE ?;subst. - by exists vm2;split=> //=;apply sem_seq1;constructor;apply: Ewhile_false=> //;rewrite H1. + by exists vm2 => //=;apply sem_seq1;constructor;apply: Ewhile_false=> //;rewrite H1. Qed. Local Lemma Rfor : sem_Ind_for p ev Pi_r Pfor. Proof. - move=> s1 s2 i d lo hi c vlo vhi H H' _ Hfor ii vm1 Hvm1 Hwf. - have [? H1 /value_uinclE H2]:= sem_pexpr_uincl Hvm1 H;subst. - have [? H3 /value_uinclE H4]:= sem_pexpr_uincl Hvm1 H';subst. - have [vm2 []???]:= Hfor _ Hvm1 Hwf; exists vm2;split=>//=. - by apply sem_seq1;constructor; econstructor;eauto;rewrite ?H1 ?H3. + move=> s1 s2 i d lo hi c vlo vhi H H' _ Hfor ii vm1 Hvm1. + have [? H1 /value_uinclE H2]:= sem_pexpr_uincl Hvm1 H; subst. + have [? H3 /value_uinclE H4]:= sem_pexpr_uincl Hvm1 H'; subst. + have [vm2 ??]:= Hfor _ Hvm1; exists vm2 => //=. + by apply sem_seq1;constructor; econstructor; eauto; rewrite ?H1 ?H3. Qed. Local Lemma Rfor_nil : sem_Ind_for_nil Pfor. - Proof. by move=> s i c vm1 Hvm1;exists vm1;split=> //;constructor. Qed. + Proof. by move=> s i c vm1 Hvm1; exists vm1 => //; constructor. Qed. Local Lemma Rfor_cons : sem_Ind_for_cons p ev Pc Pfor. Proof. - move=> s1 s1' s2 s3 i w ws c Hi _ Hc _ Hf vm1 Hvm1 Hwf. - have [vm1' Hi' /Hc] := write_var_uincl Hvm1 (value_uincl_refl _) Hi. - have /(_ Hwf) /= Hwf' := wf_write_var _ Hi'. - move=> /(_ Hwf') [vm2 [Hsc /Hf H /H]] [vm3 [Hsf Hvm3]];exists vm3;split => //. - by econstructor;eauto. + move=> s1 s1' s2 s3 i w ws c Hi _ Hc _ Hf vm1 Hvm1. + have [vm1' Hi' /Hc [vm2 Hsc /Hf [vm3 Hsf Hvm3]]] := write_var_uincl Hvm1 (value_uincl_refl _) Hi. + exists vm3 => //; econstructor; eauto. Qed. Local Lemma Rcall : sem_Ind_call p ev Pi_r Pfun. Proof. - move=> s1 scs2 m2 s2 ii xs fn args vargs vs Hargs Hcall Hfd Hxs ii' vm1 Hvm1 Hwf. + move=> s1 scs2 m2 s2 ii xs fn args vargs vs Hargs Hcall Hfd Hxs ii' vm1 Hvm1. have [vargs' Hsa /Hfd [vres' [Hc Hvres]]]:= sem_pexprs_uincl Hvm1 Hargs. have /(_ _ Hvm1) [vm2' Hw ?] := writes_uincl _ Hvres Hxs. - exists vm2';split=>//=. - + by apply: sem_seq1;constructor; econstructor;eauto. - by apply: wf_write_lvals Hw. + exists vm2' => //=; apply: sem_seq1; constructor; econstructor; eauto. Qed. Local Lemma Rproc : sem_Ind_proc p ev Pc Pfun. Proof. move=> scs1 m1 scs2 m2 fn fd vargs vargs' s0 s1 s2 vres vres' Hget Htin Hi Hargs Hsem Hrec Hmap Htout Hsys Hfi vargs1' Uargs. - have [vargs1 Htin1 Uargs1]:= mapM2_truncate_val Htin Uargs. + have [vargs1 Htin1 Uargs1]:= mapM2_dc_truncate_val Htin Uargs. have [vm1 /= ]:= write_vars_uincl (vm_uincl_refl _) Uargs1 Hargs. rewrite with_vm_same => Hargs' Hvm1. - have Hwf1 := wf_write_vars (wf_init Hi wf_vmap0) Hargs'. - have [vm2' /= [] Hsem' Uvm2 Hwf2]:= Hrec _ Hvm1 Hwf1. + have [vm2' /= Hsem' Uvm2]:= Hrec _ Hvm1. have [vres1 Hvres Hsub] := get_vars_uincl Uvm2 Hmap. - have [vres1' Htout1 Ures1]:= mapM2_truncate_val Htout Hsub. - exists vres1';split => //. + have [vres1' Htout1 Ures1]:= mapM2_dc_truncate_val Htout Hsub. + exists vres1'; split => //. apply: (EcallRun (f:=remove_init_fd is_reg_array fd)); eauto. by rewrite /p' /remove_init_prog get_map_prog Hget. Qed. @@ -296,32 +270,32 @@ Section ADD_INIT. Notation p' := (add_init_prog p). - Definition undef_except (X:Sv.t) (vm:vmap) := - forall x, ~Sv.In x X -> vm.[x] = pundef_addr (vtype x). + Definition undef_except (X:Sv.t) vm := + forall x, ~Sv.In x X -> vm.[x] = undef_addr (vtype x). Let Pi s1 (i:instr) s2 := - (forall vm1, evm s1 =v vm1 -> - exists2 vm2, evm s2 =v vm2 & sem_I p' ev (with_vm s1 vm1) i (with_vm s2 vm2)) /\ + (forall vm1, evm s1 =1 vm1 -> + exists2 vm2, evm s2 =1 vm2 & sem_I p' ev (with_vm s1 vm1) i (with_vm s2 vm2)) /\ forall I, undef_except I (evm s1) -> undef_except (add_init_i I i).2 (evm s2) /\ - forall vm1, evm s1 =v vm1 -> - exists2 vm2, evm s2 =v vm2 & + forall vm1, evm s1 =1 vm1 -> + exists2 vm2, evm s2 =1 vm2 & sem p' ev (with_vm s1 vm1) (add_init_i I i).1 (with_vm s2 vm2). Let Pi_r s1 (i:instr_r) s2 := forall ii, Pi s1 (MkI ii i) s2. Let Pc s1 (c:cmd) s2 := - (forall vm1, evm s1 =v vm1 -> - exists2 vm2, evm s2 =v vm2 & sem p' ev (with_vm s1 vm1) c (with_vm s2 vm2)) /\ + (forall vm1, evm s1 =1 vm1 -> + exists2 vm2, evm s2 =1 vm2 & sem p' ev (with_vm s1 vm1) c (with_vm s2 vm2)) /\ forall I, undef_except I (evm s1) -> undef_except (add_init_c add_init_i I c).2 (evm s2) /\ - forall vm1, evm s1 =v vm1 -> - exists2 vm2, evm s2 =v vm2 & + forall vm1, evm s1 =1 vm1 -> + exists2 vm2, evm s2 =1 vm2 & sem p' ev (with_vm s1 vm1) (add_init_c add_init_i I c).1 (with_vm s2 vm2). Let Pfor (i:var_i) vs s1 c s2 := - forall vm1, evm s1 =v vm1 -> - exists2 vm2, evm s2 =v vm2 & sem_for p' ev i vs (with_vm s1 vm1) c (with_vm s2 vm2). + forall vm1, evm s1 =1 vm1 -> + exists2 vm2, evm s2 =1 vm2 & sem_for p' ev i vs (with_vm s1 vm1) c (with_vm s2 vm2). Let Pfun scs m fn vargs scs' m' vres := sem_call p' ev scs m fn vargs scs' m' vres. @@ -346,16 +320,16 @@ Section ADD_INIT. Lemma add_initP ii i s1 s2 I X: undef_except I (evm s1) → - (∀ vm1 : vmap, evm s1 =v vm1 → exists2 vm2 : vmap, evm s2 =v vm2 & sem_I p' ev (with_vm s1 vm1) (MkI ii i) (with_vm s2 vm2)) → - ∀ vm1 : vmap, evm s1 =v vm1 → - exists2 vm2 : vmap, - evm s2 =v vm2 & sem p' ev (with_vm s1 vm1) (add_init ii I X (MkI ii i)) (with_vm s2 vm2). + (∀ vm1, evm s1 =1 vm1 → exists2 vm2, evm s2 =1 vm2 & sem_I p' ev (with_vm s1 vm1) (MkI ii i) (with_vm s2 vm2)) → + ∀ vm1, evm s1 =1 vm1 → + exists2 vm2, + evm s2 =1 vm2 & sem p' ev (with_vm s1 vm1) (add_init ii I X (MkI ii i)) (with_vm s2 vm2). Proof. move=> hu hs; rewrite /add_init Sv.fold_spec. - have : forall x:var, x \in Sv.elements (Sv.diff X I) -> (evm s1).[x] = pundef_addr (vtype x). + have : forall x:var, x \in Sv.elements (Sv.diff X I) -> (evm s1).[x] = undef_addr (vtype x). + by move=> x /Sv_elemsP hx; rewrite hu //; SvD.fsetdec. - have : ∀ vm1 : vmap, evm s1 =v vm1 → - exists2 vm2 : vmap, evm s2 =v vm2 & sem p' ev (with_vm s1 vm1) [:: MkI ii i] (with_vm s2 vm2). + have : ∀ vm1, evm s1 =1 vm1 → + exists2 vm2, evm s2 =1 vm2 & sem p' ev (with_vm s1 vm1) [:: MkI ii i] (with_vm s2 vm2). + by move=> vm1 /hs [vm2] ??; exists vm2 => //;apply sem_seq1. clear; elim: Sv.elements s1 [:: MkI ii i] => [ | x xs ih] //= s1 l hl hu. apply ih; last by move=> y hy; apply hu; rewrite in_cons hy orbT. @@ -363,31 +337,29 @@ Section ADD_INIT. have hl1 := hl _ hu1. case heq: vtype => [||len|] //; case:ifP => _ //. set i' := MkI _ _. - have [vm2 heq2 hi']: exists2 vm2, evm s1 =v vm2 & sem_I p' ev (with_vm s1 vm1) i' (with_vm s1 vm2). - + rewrite /i'; have := hu x; rewrite in_cons eq_refl /= => /(_ erefl) {hu i'}. - case: x heq => ty xn /= -> /= hx. - set x := {|vtype := _|}. - exists (vm1.[x <- ok (WArray.empty len)])%vmap. - + move=> y; case: (x =P y) => [<- | /eqP hne]. - + by rewrite Fv.setP_eq hx. - by rewrite Fv.setP_neq // hu1. + have [vm2 heq2 hi']: exists2 vm2, evm s1 =1 vm2 & sem_I p' ev (with_vm s1 vm1) i' (with_vm s1 vm2). + + rewrite /i'; have := hu x; rewrite in_cons eq_refl /= => /(_ erefl) {hu i'} hx. + exists (vm1.[x <- Varr (WArray.empty len)]). + + move: hu1; rewrite !vm_eq_vm_rel => hu1; apply vm_rel_set_r. + + by move=> _ /=; rewrite hx heq eqxx. + by apply: vm_relI hu1. constructor; econstructor; first reflexivity. + by rewrite /truncate_val /= WArray.castK. - by rewrite /= /write_var /= /set_var /= WArray.castK. + by apply /write_varP; econstructor => //=; rewrite heq /truncatable eqxx. by have [vm3 ? hc']:= hl _ heq2; exists vm3 => //; apply: Eseq hc'. Qed. Local Lemma aux ii i s1 s2 : sem_I p ev s1 (MkI ii i) s2 → - (∀ vm1 : vmap, evm s1 =v vm1 → - exists2 vm2 : vmap, evm s2 =v vm2 & sem_I p' ev (with_vm s1 vm1) (MkI ii i) (with_vm s2 vm2)) → - (∀ vm1 : vmap, evm s1 =v vm1 → - exists2 vm2 : vmap, evm s2 =v vm2 & sem_I p' ev (with_vm s1 vm1) (MkI ii i) (with_vm s2 vm2)) /\ + (∀ vm1, evm s1 =1 vm1 → + exists2 vm2, evm s2 =1 vm2 & sem_I p' ev (with_vm s1 vm1) (MkI ii i) (with_vm s2 vm2)) → + (∀ vm1, evm s1 =1 vm1 → + exists2 vm2, evm s2 =1 vm2 & sem_I p' ev (with_vm s1 vm1) (MkI ii i) (with_vm s2 vm2)) /\ forall I, undef_except I (evm s1) → undef_except (Sv.union I (write_i i)) (evm s2) /\ - ∀ vm1 : vmap, evm s1 =v vm1 → - exists2 vm2 : vmap, - evm s2 =v vm2 & + ∀ vm1, evm s1 =1 vm1 → + exists2 vm2, + evm s2 =1 vm2 & sem p' ev (with_vm s1 vm1) (add_init ii I (Sv.union (write_i i) (read_i i)) (MkI ii i)) (with_vm s2 vm2). Proof. @@ -397,54 +369,6 @@ Section ADD_INIT. by apply add_initP. Qed. - Lemma sem_pexpr_ext_eq s e vm : - evm s =v vm -> - sem_pexpr gd s e = sem_pexpr gd (with_vm s vm) e. - Proof. move=> heq. by apply: read_e_eq_on_empty. Qed. - - Lemma sem_pexprs_ext_eq s es vm : - evm s =v vm -> - sem_pexprs gd s es = sem_pexprs gd (with_vm s vm) es. - Proof. move=> heq. by apply: read_es_eq_on_empty. Qed. - - Lemma write_lvar_ext_eq x v s1 s2 vm1 : - evm s1 =v vm1 -> - write_lval gd x v s1 = ok s2 -> - exists2 vm2, evm s2 =v vm2 & write_lval gd x v (with_vm s1 vm1) = ok (with_vm s2 vm2). - Proof. - move=> he hw. - have hsub : Sv.Subset (read_rv x) (read_rv x) by SvD.fsetdec. - have heq : evm s1 =[read_rv x] vm1 by move=> ??;rewrite he. - have [vm2 [heq2 hw2]]:= write_lval_eq_on hsub hw heq. - exists vm2 => //. - move=> y; case: (Sv_memP y (vrv x)) => hin. - + by apply heq2; SvD.fsetdec. - have hd : disjoint (Sv.singleton y) (vrv x). - + by rewrite /disjoint /is_true Sv.is_empty_spec; SvD.fsetdec. - rewrite -(disjoint_eq_on hd hw); last SvD.fsetdec. - have := disjoint_eq_on hd hw2. - rewrite /with_vm /= => <- //; SvD.fsetdec. - Qed. - - Lemma write_lvars_ext_eq xs vs s1 s2 vm1 : - evm s1 =v vm1 -> - write_lvals gd s1 xs vs = ok s2 -> - exists2 vm2, evm s2 =v vm2 & write_lvals gd (with_vm s1 vm1) xs vs = ok (with_vm s2 vm2). - Proof. - move=> he hw. - have hsub : Sv.Subset (read_rvs xs) (read_rvs xs) by SvD.fsetdec. - have heq : evm s1 =[read_rvs xs] vm1 by move=> ??;rewrite he. - have [vm2 [heq2 hw2]]:= write_lvals_eq_on hsub hw heq. - exists vm2 => //. - move=> y; case: (Sv_memP y (vrvs xs)) => hin. - + by apply heq2; SvD.fsetdec. - have hd : disjoint (Sv.singleton y) (vrvs xs). - + by rewrite /disjoint /is_true Sv.is_empty_spec; SvD.fsetdec. - rewrite -(disjoint_eq_ons hd hw); last SvD.fsetdec. - have := disjoint_eq_ons hd hw2. - rewrite /with_vm /= => <- //; SvD.fsetdec. - Qed. - Local Lemma RAasgn : sem_Ind_assgn p Pi_r. Proof. move=> s1 s2 x tag ty e v v' hse htr hwr ii /=. @@ -453,7 +377,7 @@ Section ADD_INIT. move=> vm1 heq1. have [vm2 heq2 hwr2 ]:= write_lvar_ext_eq heq1 hwr. exists vm2 => //; constructor; econstructor; eauto. - by rewrite -(sem_pexpr_ext_eq e heq1). + by rewrite -(sem_pexpr_ext_eq _ _ e heq1). Qed. Local Lemma RAopn : sem_Ind_opn p Pi_r. @@ -464,7 +388,7 @@ Section ADD_INIT. move: hso; rewrite /sem_sopn; t_xrbindP => vs vs' hse ho hwr vm1 heq1. have [vm2 heq2 hwr2 ]:= write_lvars_ext_eq heq1 hwr. exists vm2 => //; constructor; econstructor; eauto. - by rewrite /sem_sopn -(sem_pexprs_ext_eq es heq1) hse /= ho. + by rewrite /sem_sopn -(sem_pexprs_ext_eq _ _ es heq1) hse /= ho. Qed. Local Lemma RAsyscall : sem_Ind_syscall p Pi_r. @@ -475,35 +399,35 @@ Section ADD_INIT. move=> vm1 heq1. have [vm2 heq2 hw2 ]:= write_lvars_ext_eq (s1 := with_scs (with_mem s1 m) scs) heq1 hw. exists vm2 => //; constructor; econstructor; eauto. - by rewrite -(sem_pexprs_ext_eq es heq1). + by rewrite -(sem_pexprs_ext_eq _ _ es heq1). Qed. Local Lemma RAif_true : sem_Ind_if_true p ev Pc Pi_r. Proof. move=> s1 s2 e c1 c2 H _ [] hs Hc ii /=; split. + move=> vm1 /dup[] heq1 /hs [vm2] ? hc; exists vm2 => //; constructor. - by apply: Eif_true => //; rewrite -(sem_pexpr_ext_eq e heq1). + by apply: Eif_true => //; rewrite -(sem_pexpr_ext_eq _ _ e heq1). move=> I /dup [] hu1 /Hc [] /=. case: (add_init_c _ _ c1)=> /= c1' O1; case: (add_init_c _ _ c2)=> /= c2' O2. move=> hu2 hsc'; split. + by move=> ??;rewrite hu2 //;SvD.fsetdec. apply add_initP => //. move=> vm1 /dup[] heq1 /hsc' [vm2 he hs']; exists vm2 => //. - by constructor; apply: Eif_true => //; rewrite -(sem_pexpr_ext_eq e heq1). + by constructor; apply: Eif_true => //; rewrite -(sem_pexpr_ext_eq _ _ e heq1). Qed. Local Lemma RAif_false : sem_Ind_if_false p ev Pc Pi_r. Proof. move=> s1 s2 e c1 c2 H _ [] hs Hc ii /=; split. + move=> vm1 /dup[] heq1 /hs [vm2] ? hc; exists vm2 => //; constructor. - by apply: Eif_false => //; rewrite -(sem_pexpr_ext_eq e heq1). + by apply: Eif_false => //; rewrite -(sem_pexpr_ext_eq _ _ e heq1). move=> I /dup [] hu1 /Hc [] /=. case: (add_init_c _ _ c1)=> /= c1' O1; case: (add_init_c _ _ c2)=> /= c2' O2. move=> hu2 hsc'; split. + by move=> ??;rewrite hu2 //;SvD.fsetdec. apply add_initP => //. move=> vm1 /dup[] heq1 /hsc' [vm2 he hs']; exists vm2 => //. - by constructor; apply: Eif_false => //; rewrite -(sem_pexpr_ext_eq e heq1). + by constructor; apply: Eif_false => //; rewrite -(sem_pexpr_ext_eq _ _ e heq1). Qed. Local Lemma RAwhile_true : sem_Ind_while_true p ev Pc Pi_r. @@ -514,7 +438,7 @@ Section ADD_INIT. + by constructor;apply: Ewhile_true;eauto. move=> vm1 /Hc [vm2] /dup[] heq /Hc' [vm3] /Hi [vm4] ? /sem_IE h *; exists vm4 => //. constructor;apply: Ewhile_true;eauto. - by rewrite -(sem_pexpr_ext_eq e heq). + by rewrite -(sem_pexpr_ext_eq _ _ e heq). Qed. Local Lemma RAwhile_false : sem_Ind_while_false p ev Pc Pi_r. @@ -524,7 +448,7 @@ Section ADD_INIT. + by constructor;apply: Ewhile_false;eauto. move=> vm1 /Hc [vm2] heq ?; exists vm2 => //. constructor;apply: Ewhile_false;eauto. - by rewrite -(sem_pexpr_ext_eq e heq). + by rewrite -(sem_pexpr_ext_eq _ _ e heq). Qed. Local Lemma RAfor : sem_Ind_for p ev Pi_r Pfor. @@ -533,7 +457,7 @@ Section ADD_INIT. apply aux. + by constructor; econstructor; eauto. move=> vm1 /dup [] heq /hf [vm2] ? hs'; exists vm2 => //. - by constructor; econstructor; eauto; rewrite -(sem_pexpr_ext_eq _ heq). + by constructor; econstructor; eauto; rewrite -(sem_pexpr_ext_eq _ _ _ heq). Qed. Local Lemma RAfor_nil : sem_Ind_for_nil Pfor. @@ -542,7 +466,7 @@ Section ADD_INIT. Local Lemma RAfor_cons : sem_Ind_for_cons p ev Pc Pfor. Proof. move=> s1 s1' s2 s3 i w ws c Hi _ [] Hc _ _ Hf vm1 Hvm1. - have [vm2 /Hc [vm3] /Hf [vm4] *]:= write_lvar_ext_eq Hvm1 (Hi : write_lval gd i w s1 = ok s1'). + have [vm2 /Hc [vm3] /Hf [vm4] *]:= write_lvar_ext_eq Hvm1 (Hi : write_lval true gd i w s1 = ok s1'). exists vm4 => //; by econstructor; eauto. Qed. @@ -552,10 +476,10 @@ Section ADD_INIT. apply aux. + constructor; econstructor;eauto. move=> vm1 heq1. - have heq1' : evm (with_mem s1 m2) =v vm1 := heq1. + have heq1' : evm (with_mem s1 m2) =1 vm1 := heq1. have [vm2 heq2 hwr2 ]:= write_lvars_ext_eq (s1 := (with_scs (with_mem s1 m2) scs2)) heq1 Hxs. exists vm2 => //; constructor; econstructor; eauto. - by rewrite -(sem_pexprs_ext_eq args). + by rewrite -(sem_pexprs_ext_eq _ _ args). Qed. Local Lemma RAproc : sem_Ind_proc p ev Pc Pfun. @@ -566,8 +490,8 @@ Section ADD_INIT. set I := vrvs [seq (Lvar i) | i <- f_params fd]. case: (Hrec I). + move=> x hx. - move: Hargs; rewrite (write_vars_lvals gd) => /disjoint_eq_ons -/(_ (Sv.singleton x)) <-. - + by move: Hi => [<-] /=; rewrite Fv.get0. + move: Hargs; rewrite (write_vars_lvals _ gd) => /disjoint_eq_ons -/(_ (Sv.singleton x)) <-. + + by move: Hi => [<-] /=; rewrite Vm.initP. + by rewrite -/I /disjoint /is_true Sv.is_empty_spec; SvD.fsetdec. by SvD.fsetdec. move=> ? /(_ (evm s1) (fun _ => erefl)) [vm2] heq2 hsem {Hsem Hget}. diff --git a/proofs/compiler/compiler.v b/proofs/compiler/compiler.v index a92870c4f..c8fc8bf3a 100644 --- a/proofs/compiler/compiler.v +++ b/proofs/compiler/compiler.v @@ -87,9 +87,9 @@ Variant compiler_step := | RemovePhiNodes : compiler_step | DeadCode_Renaming : compiler_step | RemoveArrInit : compiler_step + | MakeRefArguments : compiler_step | RegArrayExpansion : compiler_step | RemoveGlobal : compiler_step - | MakeRefArguments : compiler_step | LowerInstruction : compiler_step | SLHLowering : compiler_step | PropagateInline : compiler_step @@ -117,12 +117,12 @@ Definition compiler_step_list := [:: ; RemovePhiNodes ; DeadCode_Renaming ; RemoveArrInit + ; MakeRefArguments ; RegArrayExpansion ; RemoveGlobal - ; MakeRefArguments ; LowerInstruction ; SLHLowering - ; PropagateInline + ; PropagateInline ; StackAllocation ; RemoveReturn ; RegAllocation @@ -233,7 +233,7 @@ Definition live_range_splitting (p: uprog) : cexec uprog := let pv := remove_phi_nodes_prog pv in let pv := cparams.(print_uprog) RemovePhiNodes pv in let pv := map_prog_name (refresh_instr_info cparams) pv in - Let _ := check_uprog p.(p_extra) p.(p_funcs) pv.(p_extra) pv.(p_funcs) in + Let _ := check_uprog (wsw:= withsubword) p.(p_extra) p.(p_funcs) pv.(p_extra) pv.(p_funcs) in Let pv := dead_code_prog (ap_is_move_op aparams) pv false in let p := cparams.(print_uprog) DeadCode_Renaming pv in ok p. @@ -246,7 +246,7 @@ Definition compiler_first_part (to_keep: seq funname) (p: prog) : cexec uprog := let p := add_init_prog p in let p := cparams.(print_uprog) AddArrInit p in - Let p := inline_prog_err cparams.(rename_fd) p in + Let p := inline_prog_err (wsw:= withsubword) cparams.(rename_fd) p in let p := cparams.(print_uprog) Inlining p in Let p := dead_calls_err_seq to_keep p in @@ -260,7 +260,10 @@ Definition compiler_first_part (to_keep: seq funname) (p: prog) : cexec uprog := let pr := remove_init_prog cparams.(is_reg_array) pv in let pr := cparams.(print_uprog) RemoveArrInit pr in - Let pe := expand_prog cparams.(expand_fd) pr in + Let pa := makereference_prog (fresh_var_ident cparams (Reg (Normal, Pointer Writable))) pr in + let pa := cparams.(print_uprog) MakeRefArguments pa in + + Let pe := expand_prog cparams.(expand_fd) to_keep pa in let pe := cparams.(print_uprog) RegArrayExpansion pe in Let pe := live_range_splitting pe in @@ -268,12 +271,9 @@ Definition compiler_first_part (to_keep: seq funname) (p: prog) : cexec uprog := Let pg := remove_glob_prog cparams.(fresh_id) pe in let pg := cparams.(print_uprog) RemoveGlobal pg in - Let pa := makereference_prog (fresh_var_ident cparams (Reg (Normal, Pointer Writable))) pg in - let pa := cparams.(print_uprog) MakeRefArguments pa in - Let _ := assert - (lop_fvars_correct loparams (fresh_var_ident cparams (Reg (Normal, Direct)) dummy_instr_info) (p_funcs pa)) + (lop_fvars_correct loparams (fresh_var_ident cparams (Reg (Normal, Direct)) dummy_instr_info) (p_funcs pg)) (pp_internal_error_s "lowering" "lowering check fails") in @@ -283,7 +283,7 @@ Definition compiler_first_part (to_keep: seq funname) (p: prog) : cexec uprog := (lowering_opt cparams) (warning cparams) (fresh_var_ident cparams (Reg (Normal, Direct)) dummy_instr_info) - pa + pg in let pl := cparams.(print_uprog) LowerInstruction pl in @@ -304,7 +304,7 @@ Definition compiler_third_part (entries: seq funname) (ps: sprog) : cexec sprog let pa := {| p_funcs := cparams.(regalloc) pr.(p_funcs) ; p_globs := pr.(p_globs) ; p_extra := pr.(p_extra) |} in let pa : sprog := cparams.(print_sprog) RegAllocation pa in - Let _ := check_sprog pr.(p_extra) pr.(p_funcs) pa.(p_extra) pa.(p_funcs) in + Let _ := check_sprog (wsw:= withsubword) pr.(p_extra) pr.(p_funcs) pa.(p_extra) pa.(p_funcs) in Let pd := dead_code_prog (ap_is_move_op aparams) pa true in let pd := cparams.(print_sprog) DeadCode_RegAllocation pd in diff --git a/proofs/compiler/compiler_proof.v b/proofs/compiler/compiler_proof.v index 290ac1475..49ba2e808 100644 --- a/proofs/compiler/compiler_proof.v +++ b/proofs/compiler/compiler_proof.v @@ -1,5 +1,5 @@ From mathcomp Require Import all_ssreflect all_algebra. -Require Import sem. + Require Import arch_params_proof compiler @@ -26,7 +26,9 @@ Require Import linearization_proof merge_varmaps_proof psem_of_sem_proof - slh_lowering_proof. + slh_lowering_proof + direct_call_proof. + Require Import arch_decl arch_extra @@ -40,6 +42,8 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. +#[local] Existing Instance withsubword. + Section PROOF. Context @@ -57,7 +61,7 @@ Hypothesis print_linearP : forall s p, cparams.(print_linear) s p = p. #[local] Existing Instance progUnit. -Lemma postprocessP (p p': uprog) ev scs m fn va scs' m' vr va' : +Lemma postprocessP {dc : DirectCall} (p p': uprog) ev scs m fn va scs' m' vr va' : dead_code_prog (ap_is_move_op aparams) (const_prop_prog p) false = ok p' → sem_call p ev scs m fn va scs' m' vr → List.Forall2 value_uincl va va' → @@ -78,7 +82,7 @@ Proof. exact: value_uincl_trans. Qed. -Lemma unrollP (fn : funname) (p p' : prog) ev scs mem va va' scs' mem' vr : +Lemma unrollP {dc : DirectCall} (fn : funname) (p p' : prog) ev scs mem va va' scs' mem' vr : unroll_loop (ap_is_move_op aparams) p = ok p' -> sem_call p ev scs mem fn va scs' mem' vr -> List.Forall2 value_uincl va va' @@ -128,12 +132,12 @@ Definition compose_pass_uincl' : ∀ vr (P Q: _ → Prop), let 'ex_intro2 vr2 v q := h _ p in ex_intro2 _ _ vr2 (Forall2_trans value_uincl_trans u v) q. -Lemma live_range_splittingP (p p': uprog) scs m fn va scs' m' vr : +Lemma live_range_splittingP {dc : DirectCall} (p p': uprog) scs m fn va scs' m' vr : live_range_splitting aparams cparams p = ok p' → - psem.sem_call p tt scs m fn va scs' m' vr → + sem_call p tt scs m fn va scs' m' vr → exists2 vr', List.Forall2 value_uincl vr vr' & - psem.sem_call p' tt scs m fn va scs' m' vr'. + sem_call p' tt scs m fn va scs' m' vr'. Proof. rewrite /live_range_splitting; t_xrbindP. rewrite !print_uprogP => ok_p' pa ok_pa. @@ -154,10 +158,10 @@ Qed. Lemma compiler_first_partP entries (p: prog) (p': uprog) scs m fn va scs' m' vr : compiler_first_part aparams cparams entries p = ok p' → fn \in entries → - sem.sem_call p scs m fn va scs' m' vr → + sem_call (wsw:= nosubword) (dc:=indirect_c) p tt scs m fn va scs' m' vr → exists2 vr', List.Forall2 value_uincl vr vr' & - psem.sem_call p' tt scs m fn va scs' m' vr'. + sem_call (dc:=direct_c) p' tt scs m fn va scs' m' vr'. Proof. rewrite /compiler_first_part; t_xrbindP => pa0. rewrite print_uprogP => ok_pa0 pa. @@ -166,19 +170,18 @@ Proof. rewrite print_uprogP => ok_pc. rewrite !print_uprogP => pd ok_pd. rewrite !print_uprogP => pe ok_pe. - rewrite !print_uprogP => pf ok_pf pg ok_pg. - rewrite !print_uprogP => ph ok_ph. + rewrite !print_uprogP => pf ok_pf. + rewrite !print_uprogP => pg ok_pg ph ok_ph. rewrite !print_uprogP => ok_fvars pi ok_pi pp. rewrite !print_uprogP => ok_pp <- {p'} ok_fn exec_p. + have va_refl := List_Forall2_refl va value_uincl_refl. apply: compose_pass_uincl. - - move=> vr' Hvr'. - apply: (pi_callP (sCP := sCP_unit) (hpip := hap_hpip haparams) ok_pp va_refl). - exact: Hvr'. - apply: compose_pass. - - move=> vr' Hvr'. - assert (h := lower_slh_prog_sem_call (hap_hshp haparams) (ev:= tt) ok_pi). - apply h => //; exact Hvr'. + - move=> vr'; apply: (pi_callP (sCP := sCP_unit) (hpip := hap_hpip haparams) ok_pp va_refl). + apply: compose_pass. + - move=> vr'. + assert (h := lower_slh_prog_sem_call (dc:=direct_c) (hap_hshp haparams) (ev:= tt) ok_pi). + apply h => //. apply: compose_pass. - move => vr'. exact: @@ -187,27 +190,27 @@ Proof. (lowering_opt cparams) (warning cparams) ok_fvars). - apply: compose_pass; - first by move=> vr'; - apply: (makeReferenceArguments_callP (siparams := sip_of_asm_e) ok_ph). - apply: compose_pass; first by move => vr'; apply: (RGP.remove_globP ok_pg). + apply: compose_pass; first by move => vr'; apply: (RGP.remove_globP ok_ph). apply: compose_pass_uincl'. - - move => vr' Hvr'. - apply: (live_range_splittingP ok_pf); exact: Hvr'. - apply: compose_pass; - first by move=> vr'; apply:(expand_callP (sip := sip_of_asm_e) ok_pe). + - move => vr'; apply: (live_range_splittingP ok_pg). + apply: compose_pass. + - move=> vr' hvr'. assert (h := expand_callP (sip := sip_of_asm_e) ok_pf); apply h => //; apply hvr'. + apply: compose_pass_uincl'. + - by move=> vr'; apply: indirect_2_direct. + apply: compose_pass. + - by move=> vr'; apply: (makeReferenceArguments_callP (siparams := sip_of_asm_e) ok_pe). apply: compose_pass_uincl; first by move =>vr'; apply: (remove_init_fdPu _ va_refl). apply: compose_pass_uincl'. - move => vr' Hvr'. apply: (live_range_splittingP ok_pd); exact: Hvr'. apply: compose_pass_uincl; first by move=> vr' Hvr'; apply: (unrollP ok_pc _ va_refl); exact: Hvr'. apply: compose_pass. - - move => vr'; - exact: (dead_calls_err_seqP (sip := sip_of_asm_e) (sCP := sCP_unit) ok_pb). + - by move => vr'; exact: (dead_calls_err_seqP (sip := sip_of_asm_e) (sCP := sCP_unit) ok_pb). apply: compose_pass_uincl; first by move => vr' Hvr'; apply: (inline_call_errP ok_pa va_refl); exact: Hvr'. apply: compose_pass; first by move => vr'; apply: (add_init_fdP). - apply: compose_pass_uincl; first by move=> vr' Hvr'; apply: (array_copy_fdP (sCP := sCP_unit) ok_pa0 va_refl); exact Hvr'. - apply: compose_pass; first by move => vr'; exact: psem_call. + apply: compose_pass_uincl. + - by move=> vr'; apply:(array_copy_fdP (sCP := sCP_unit) ok_pa0 va_refl). + apply: compose_pass; first by move => vr'; exact: psem_call_u. exists vr => //. exact: (List_Forall2_refl _ value_uincl_refl). Qed. @@ -226,10 +229,10 @@ Lemma compiler_third_partP entries (p p' : @sprog _pd _ _asmop) : [/\ ∀ fn (gd: pointer) scs m va scs' m' vr, fn \in entries → - psem.sem_call p gd scs m fn va scs' m' vr → + sem_call (dc:= direct_c) p gd scs m fn va scs' m' vr → exists2 vr', List.Forall2 value_uincl vr vr' & - psem.sem_call p' gd scs m fn va scs' m' vr' & + sem_call (dc:= direct_c) p' gd scs m fn va scs' m' vr' & ∀ fn m, alloc_ok p' fn m → alloc_ok p fn m ]. @@ -242,9 +245,8 @@ Proof. have va_refl : List.Forall2 value_uincl va va. - exact: List_Forall2_refl. apply: compose_pass_uincl. - - move => vr' Hvr'. - apply: (dead_code_callPs (hap_is_move_opP haparams) ok_pc va_refl). - exact: Hvr'. + - move => vr'. + apply: (dead_code_callPs (dc:= direct_c) (hap_is_move_opP haparams) ok_pc va_refl). apply: compose_pass_uincl; first by move => vr'; apply: @@ -313,7 +315,7 @@ Proof. by case => // m ih []. Qed. -Lemma sem_call_length (p: uprog) scs m fn va scs' m' vr : +Lemma sem_call_length {dc:DirectCall}(p: uprog) scs m fn va scs' m' vr : sem_call p tt scs m fn va scs' m' vr → ∃ fd, [/\ get_fundef (p_funcs p) fn = Some fd, @@ -338,13 +340,13 @@ Lemma compiler_front_endP scs m mi fn va scs' m' vr : compiler_front_end aparams cparams entries p = ok p' → fn \in entries → - sem.sem_call p scs m fn va scs' m' vr → + sem_call (dc:=indirect_c) (wsw:= nosubword) p tt scs m fn va scs' m' vr → extend_mem m mi gd (sp_globs (p_extra p')) → alloc_ok p' fn mi → ∃ vr' mi', [/\ List.Forall2 value_uincl vr vr', - psem.sem_call p' gd scs mi fn va scs' mi' vr' & + sem_call (dc:=direct_c) p' gd scs mi fn va scs' mi' vr' & extend_mem m' mi' gd (sp_globs (p_extra p')) ]. Proof. @@ -454,6 +456,11 @@ Qed. Import sem_one_varmap. +(* FIXME : move this *) +Lemma mapM_get_false vm xs : + mapM (λ x : var_i, get_var false vm x) xs = ok (map (λ x : var_i, vm.[x]) xs). +Proof. by rewrite /get_var /=; elim xs => //= ?? -> /=. Qed. + Lemma compiler_back_endP entries (p : @sprog _pd _ _asmop) @@ -468,27 +475,22 @@ Lemma compiler_back_endP res : compiler_back_end aparams cparams entries p = ok tp → fn \in entries → - psem.sem_call p rip scs m fn args scs' m' res → + psem.sem_call (dc:= direct_c) p rip scs m fn args scs' m' res → ∃ fd : lfundef, [/\ get_fundef tp.(lp_funcs) fn = Some fd, fd.(lfd_export) & - ∀ lm vm args', - wf_vm vm → - vm.[vid tp.(lp_rsp)]%vmap = ok (pword_of_word (top_stack m)) → + ∀ lm vm, + vm.[vid tp.(lp_rsp)] = Vword (top_stack m) → match_mem m lm → - mapM (λ x : var_i, get_var vm x) fd.(lfd_arg) = ok args' → - List.Forall2 value_uincl args args' → - vm.[vid tp.(lp_rip)]%vmap = ok (pword_of_word rip) → + List.Forall2 value_uincl args (map (λ x : var_i, vm.[x]) fd.(lfd_arg)) → + vm.[vid tp.(lp_rip)] = Vword rip → vm_initialized_on vm (var_tmp aparams :: lfd_callee_saved fd) → - all2 check_ty_val fd.(lfd_tyin) args' ∧ - ∃ vm' lm' res', + ∃ vm' lm', [/\ lsem_exportcall tp scs lm fn vm scs' lm' vm', - match_mem m' lm', - mapM (λ x : var_i, get_var vm' x) fd.(lfd_res) = ok res', - List.Forall2 value_uincl res res' & - all2 check_ty_val fd.(lfd_tyout) res' + match_mem m' lm' & + List.Forall2 value_uincl res (map (λ x : var_i, vm'.[x]) fd.(lfd_res)) ] ]. Proof. @@ -514,16 +516,15 @@ Proof. exists (tunneling.tunnel_lfundef fn fd); split. - exact: get_fundef_tunnel_program ok_tp ok_fd. - exact: Export. - move=> lm vm args' H H0 H1 H2 H3 H4 H5. - have {lp_call} := lp_call lm vm args' H _ H1 H2 H3 _ H5. + move=> lm vm H0 H1 H3 H4 H5. + have H2 := mapM_get_false vm (lfd_arg fd). + have {lp_call} := lp_call lm vm _ _ H1 H2 H3 _ H5. have! [-> [-> _]] := (tunnel_program_invariants ok_tp). - move => /(_ H0 H4)[] wt_args' [] vm' [] lm' [] res' [] lp_call M' ok_res' res_res' wt_res'. - split; first exact: wt_args'. - exists vm', lm', res'; split; cycle 1. + move => /(_ H0 H4) [] vm' [] lm' [] res' [] lp_call M'. + rewrite mapM_get_false => -[] <- res_res'. + exists vm', lm'; split; cycle 1. - exact: M'. - - exact: ok_res'. - exact: res_res'. - - exact: wt_res'. clear -lp_call ok_tp. case: lp_call => fd ok_fd Export lp_exec ok_callee_saved. exists (tunneling.tunnel_lfundef fn fd). @@ -548,23 +549,20 @@ Lemma compiler_back_end_to_asmP res : compiler_back_end_to_asm aparams cparams entries p = ok xp -> fn \in entries - -> psem.sem_call p rip scs m fn args scs' m' res + -> psem.sem_call (dc:=direct_c) p rip scs m fn args scs' m' res -> exists xd : asm_fundef, [/\ get_fundef (asm_funcs xp) fn = Some xd , asm_fd_export xd - & forall xm args', + & forall xm, xm.(asm_scs) = scs -> xm.(asm_rip) = rip -> asm_reg xm ad_rsp = top_stack m -> match_mem m xm.(asm_mem) - -> get_typed_reg_values xm xd.(asm_fd_arg) = ok args' - -> List.Forall2 value_uincl args args' - (* FIXME: well-typed? all2 check_ty_val fd.(asm_fd_tyin) args' ∧ *) - -> exists xm' res', + -> List.Forall2 value_uincl args (get_typed_reg_values xm xd.(asm_fd_arg)) + -> exists xm', [/\ asmsem_exportcall xp fn xm xm' , match_mem m' xm'.(asm_mem), xm'.(asm_scs) = scs' - , get_typed_reg_values xm' xd.(asm_fd_res) = ok res' - & List.Forall2 value_uincl res res' + & List.Forall2 value_uincl res (get_typed_reg_values xm' xd.(asm_fd_res)) ] ]. Proof. @@ -583,7 +581,7 @@ Proof. -> {xd}. eexists; split; first reflexivity. - by rewrite fd_export. - move=> xm args' ok_scs ok_rip ok_rsp M /= ok_args' ok_args. + move=> xm ok_scs ok_rip ok_rsp M /= ok_args. set s := estate_of_asm_mem @@ -591,8 +589,6 @@ Proof. (lp_rip lp) (lp_rsp lp) xm. - have wf_s : wf_vm (evm s). - - exact: wf_vmap_of_asm_mem. assert (LM := lom_eqv_estate_of_asm_mem @@ -608,48 +604,35 @@ Proof. (lp_rsp lp) xm). - have := lp_call _ _ _ wf_s _ M _ ok_args. - + have := lp_call _ _ _ M. + move=> /(_ (vmap_of_asm_mem (top_stack m) (lp_rip lp) (lp_rsp lp) xm)). case. - assert (Hrsp := XM (ARReg ad_rsp)). move: Hrsp. - rewrite /= /get_var /to_var /=. - rewrite ok_lp_rsp /rtype /=. - case: _.[_]%vmap => - [ | [] // ] [] /= sz w sz_le_Uptr /ok_inj /Vword_inj[] ?; - subst => /=. - by rewrite pword_of_wordE ok_rsp => ->. - - rewrite -ok_args'. - apply: mapM_factorization ok_xargs. - rewrite /typed_reg_of_vari /=. - move => [x _] r /= h. - by rewrite (asm_typed_reg_of_varI h). + by rewrite /= /to_var /= ok_lp_rsp /rtype /= ok_rsp. + - have -> //: + [seq (vmap_of_asm_mem (top_stack m) (lp_rip lp) (lp_rsp lp) xm).[v_var x] | x <- lfd_arg fd] = + (get_typed_reg_values xm xargs). + elim: (lfd_arg fd) (xargs) ok_xargs => //= [ | [x ?] xs hrec]; t_xrbindP; first by move=> _ <-. + by move=> ?? h ? /hrec -> <- /=; rewrite -XM (asm_typed_reg_of_varI h). - case: LM => _ _ Y _ _ _ _. - move: Y; rewrite /get_var /=. - rewrite /mk_ptr /=. - case: _.[_]%vmap => - /= [ | [] // ] [] /= sz w sz_le_Uptr /ok_inj /Vword_inj[] ?; - subst => /=. - by rewrite pword_of_wordE => ->. + by move: Y => /= ->; rewrite ok_rip. - move => /=. apply/andP; split. + rewrite /var_tmp. have [tmp_r htmp] := ok_lip_tmp haparams. - rewrite -(of_identI htmp). - rewrite (XM (ARReg _)). + rewrite -(of_identI htmp) /get_var (XM (ARReg _)). by rewrite /get_typed_reg_value /= truncate_word_u. apply/allP => x /ok_callee_saved hin. have [r ->]: exists2 r, x = (var_of_asm_typed_reg r) & vtype x != sbool. + by move/andP: hin => [->] /is_okP [] r /asm_typed_reg_of_varI ->; exists r. - rewrite XM /=. + rewrite /get_var XM /=. by case: r => //= ?; rewrite truncate_word_u. move=> - _wt_largs - [] vm' + vm' [] lm' - [] res' - [] {} lp_call M' ok_res' res_res' _wt_res'. + [] {} lp_call M' res_res'. subst scs. have := asm_gen_exportcall @@ -660,42 +643,22 @@ Proof. LM. case. - apply/allP => ? /mapP [] r hin ->. - rewrite (XM r) /=. + rewrite /get_var (XM r) /=. assert (H:= callee_saved_not_bool); move/allP: H => /(_ _ hin) {hin}. by case: r => //= r _; rewrite truncate_word_u. move=> xm' xp_call LM'. - - have : - exists2 res'', get_typed_reg_values xm' xres = ok res'' - & List.Forall2 value_uincl res' res''. - - move/mapM_Forall2: ok_res'. - move/mapM_Forall2: ok_xres {res_res' _wt_res'} res'. - case: LM' => /=_ _ _ _; clear => R RX X F. - elim. - + move=> _ /List_Forall2_inv_l ->. by exists [::]. - case => ? /= xi r xs rs. - move=> /asm_typed_reg_of_varI. - move=> /= -> xs_rs ih. - move=> ? /List_Forall2_inv_l[] v [] vs [] ?; subst. - case => ok_v /ih [] vs' -> vs_vs'. - suff : exists2 v', get_typed_reg_value xm' r = ok v' & value_uincl v v'. - + case => v' /= -> v_v'; exists (v' :: vs'); first by []. - by constructor. - case: r ok_v => r. - + by move => /R /= h; eexists; first reflexivity. - + by move => /RX /= h; eexists; first reflexivity. - + by move => /X /= h; eexists; first reflexivity. - rewrite get_varE; t_xrbindP => /= b ok_b ?; subst v. - have := F r b. - rewrite /= ok_b /get_rf => /(_ erefl). - by case: (asm_flag xm' r) => // _ <-; exists b. - case => res'' ok_res'' res'_res''. - exists xm', res''; split => //. + have : List.Forall2 value_uincl res (get_typed_reg_values xm' xres). + + elim: (lfd_res fd) (xres) ok_xres (res) res_res' => [ | [x ?] xs hrec] //=; t_xrbindP. + + by move=> ? <- res' h; inversion_clear h => /=. + move=> ? r h ? /hrec{}hrec <- res' /List_Forall2_inv; case: res' => // v res' [hr /hrec] /=. + apply/List.Forall2_cons/(value_uincl_trans hr). + rewrite (asm_typed_reg_of_varI h) /=. + case: LM' => /= _ _ _ _ R RX X F. + case: (r) => //=. + exists xm'; split => //. - by case: LM' => /= _ <-. - by case: LM' => <-. - apply: Forall2_trans res_res' res'_res''. - exact: value_uincl_trans. Qed. (* Agreement relation between source and target memories. @@ -724,24 +687,20 @@ Lemma compile_prog_to_asmP xm : compile_prog_to_asm aparams cparams entries p = ok xp -> fn \in entries - -> sem.sem_call p scs m fn va scs' m' vr + -> psem.sem_call (dc:= indirect_c) (wsw:=nosubword) p tt scs m fn va scs' m' vr -> mem_agreement m (asm_mem xm) (asm_rip xm) (asm_globs xp) -> enough_stack_space xp fn (top_stack m) (asm_mem xm) -> exists xd : asm_fundef, [/\ get_fundef (asm_funcs xp) fn = Some xd , asm_fd_export xd - & forall args', - asm_scs xm = scs + & asm_scs xm = scs -> asm_reg xm ad_rsp = top_stack m - -> get_typed_reg_values xm (asm_fd_arg xd) = ok args' - -> List.Forall2 value_uincl va args' - (* FIXME: see comment in compiler_back_end_to_asmP *) - -> exists xm' res', + -> List.Forall2 value_uincl va (get_typed_reg_values xm (asm_fd_arg xd)) + -> exists xm', [/\ asmsem_exportcall xp fn xm xm' , mem_agreement m' (asm_mem xm') (asm_rip xm') (asm_globs xp), asm_scs xm' = scs' - , get_typed_reg_values xm' (asm_fd_res xd) = ok res' - & List.Forall2 value_uincl vr res' + & List.Forall2 value_uincl vr (get_typed_reg_values xm' (asm_fd_res xd)) ] ]. Proof. @@ -753,13 +712,12 @@ Proof. have := compiler_front_endP ok_sp ok_fn p_call mi1 ok_mi. case => vr' [] mi' [] vr_vr' sp_call m1. have := compiler_back_end_to_asmP ok_xp ok_fn sp_call. - case => xd [] ok_xd export /(_ _ _ _ erefl _ mi2) xp_call. + case => xd [] ok_xd export /(_ _ _ erefl _ mi2) xp_call. exists xd; split => //. - move=> args' ok_scs ok_rsp ok_args' va_args'. - have := xp_call _ ok_scs ok_rsp ok_args' va_args'. - case => xm' [] res' [] {} xp_call m2 ok_scs' ok_res' vr'_res'. - exists xm', res'; - split => //; + move=> ok_scs ok_rsp va_args'. + have := xp_call ok_scs ok_rsp va_args'. + case => xm' [] {} xp_call m2 ok_scs' vr'_res'. + exists xm'; split => //; last exact: Forall2_trans value_uincl_trans vr_vr' vr'_res'. case: xp_call => _ _ _ /= _ /asmsem_invariantP /= xm_xm' _. exists mi'; split. @@ -769,7 +727,7 @@ Proof. - transitivity mi; last exact: (sem_call_stack_stable_sprog sp_call). transitivity m; last exact: mi3. - symmetry. exact: (sem_call_stack_stable p_call). + symmetry. exact: (sem_call_stack_stable_uprog p_call). rewrite -(ss_limit (sem_call_stack_stable_sprog sp_call)) -(ss_top_stack (asmsem_invariant_stack_stable xm_xm')). diff --git a/proofs/compiler/constant_prop.v b/proofs/compiler/constant_prop.v index 8a1f2f6ee..69d6f7225 100644 --- a/proofs/compiler/constant_prop.v +++ b/proofs/compiler/constant_prop.v @@ -11,7 +11,6 @@ Unset Strict Implicit. Unset Printing Implicit Defensive. Local Open Scope seq_scope. -Local Open Scope vmap_scope. Local Open Scope Z_scope. diff --git a/proofs/compiler/constant_prop_proof.v b/proofs/compiler/constant_prop_proof.v index a6d20fd60..0e1de4bb7 100644 --- a/proofs/compiler/constant_prop_proof.v +++ b/proofs/compiler/constant_prop_proof.v @@ -11,7 +11,6 @@ Unset Strict Implicit. Unset Printing Implicit Defensive. Local Open Scope seq_scope. -Local Open Scope vmap_scope. Local Notation cpm := (Mvar.t const_v). @@ -21,6 +20,8 @@ Local Notation cpm := (Mvar.t const_v). Section WITH_PARAMS. Context + {wsw:WithSubWord} + {dc:DirectCall} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} @@ -31,14 +32,14 @@ Context Section GLOB_DEFS. -Context (gd: glob_decls). +Context (wdb : bool) (gd: glob_decls). Definition eqok_w (e1 e2:pexpr) st := - forall v, sem_pexpr gd st e1 = ok v -> sem_pexpr gd st e2 = ok v. + forall v, sem_pexpr wdb gd st e1 = ok v -> sem_pexpr wdb gd st e2 = ok v. Definition eqok (e1 e2:pexpr) st := - forall v, sem_pexpr gd st e1 = ok v -> - exists v', sem_pexpr gd st e2 = ok v' /\ value_uincl v v'. + forall v, sem_pexpr wdb gd st e1 = ok v -> + exists v', sem_pexpr wdb gd st e2 = ok v' /\ value_uincl v v'. Lemma eqok_weaken e1 e2 st : eqok_w e1 e2 st -> eqok e1 e2 st. Proof. by move=> h v /h h';exists v. Qed. @@ -114,13 +115,13 @@ Proof. by case: e => //= ? [->]. Qed. Lemma of_exprP rho t e v : of_expr t e = ok v -> - Let x := sem_pexpr gd rho e in of_val t x = ok v. + Let x := sem_pexpr wdb gd rho e in of_val t x = ok v. Proof. case: t v => //= [b /e2boolP -> | z /e2intP -> | w] // v. by rewrite /e2word; case heq : is_wconst => [w' | ] // [<-]; apply is_wconstP. Qed. -Lemma to_exprP rho t (v:sem_t t) e : to_expr v = ok e -> sem_pexpr gd rho e = ok (to_val v). +Lemma to_exprP rho t (v:sem_t t) e : to_expr v = ok e -> sem_pexpr wdb gd rho e = ok (to_val v). Proof. case: t v => //= [b | z | ws w] [<-] //=. by rewrite /sem_sop1 /= wrepr_unsigned. @@ -183,16 +184,16 @@ rewrite /sadd_w. case h1: (is_wconst sz e1) => [ n1 | ]; case h2: (is_wconst sz e2) => [ n2 | ] //. + move => s v /=; rewrite /sem_sop2 /sem_sop1 /=. - have! := (is_wconstP gd s h2). - have! := (is_wconstP gd s h1). + have! := (is_wconstP wdb gd s h2). + have! := (is_wconstP wdb gd s h1). by t_xrbindP => *; clarify; rewrite wrepr_unsigned;eauto. + case: eqP => // hz s v /=; rewrite /sem_sop2 /=. - have! := (is_wconstP gd s h1). + have! := (is_wconstP wdb gd s h1). t_xrbindP => ? k1 k2 ? k3 ? k4 ? k5 ? k6 <-; clarify. case: (to_wordI k6) => sz' [w' [? /truncate_word_uincl ?]]; subst. by rewrite GRing.add0r k4;eauto. case: eqP => // hz s v /=; rewrite /sem_sop2 /=. -have! := (is_wconstP gd s h2). +have! := (is_wconstP wdb gd s h2). t_xrbindP => ? k1 k2 ? k3 ? k4 ? k5 ? k6 <-; clarify. case: (to_wordI k5) => sz' [w' [? /truncate_word_uincl ?]]; subst. by rewrite GRing.addr0 k3;eauto. @@ -217,11 +218,11 @@ rewrite /ssub_w. case h1: (is_wconst sz e1) => [ n1 | ]; case h2: (is_wconst sz e2) => [ n2 | ] //. + move => s v /=; rewrite /sem_sop2 /sem_sop1 /=. - have! := (is_wconstP gd s h2). - have! := (is_wconstP gd s h1). + have! := (is_wconstP wdb gd s h2). + have! := (is_wconstP wdb gd s h1). by t_xrbindP => *; clarify; rewrite wrepr_unsigned;eauto. case: eqP => // hz s v /=; rewrite /sem_sop2 /=. -have! := (is_wconstP gd s h2). +have! := (is_wconstP wdb gd s h2). t_xrbindP => ? k1 k2 ? k3 ? k4 ? k5 ? k6 <-; clarify. case: (to_wordI k5) => sz' [w' [? /truncate_word_uincl ?]]; subst. by rewrite GRing.subr0 k3;eauto. @@ -252,18 +253,18 @@ rewrite /smul_w. case h1: (is_wconst sz e1) => [ n1 | ]; case h2: (is_wconst sz e2) => [ n2 | ] //. + move => s v /=; rewrite /sem_sop2 /sem_sop1 /=. - have! := (is_wconstP gd s h2). - have! := (is_wconstP gd s h1). + have! := (is_wconstP wdb gd s h2). + have! := (is_wconstP wdb gd s h1). by t_xrbindP => *; clarify; rewrite wrepr_unsigned;eauto. + case: eqP => hn1; [| case: eqP => hn2] => s v /=; rewrite /sem_sop2 /sem_sop1 /=; - have! := (is_wconstP gd s h1); + have! := (is_wconstP wdb gd s h1); t_xrbindP => ? k1 k2 ? k3 ? k4 ? k5 ? k6 ?; clarify. - rewrite wrepr_unsigned GRing.mul0r;eauto. - case: (to_wordI k6) => {k6} sz' [w] [? /truncate_word_uincl]; subst. by rewrite k4 GRing.mul1r; eauto. by rewrite k4 /= k6 /= wrepr_unsigned truncate_word_u /=;eexists;split;eauto => /=. case: eqP => hn1; [| case: eqP => hn2] => s v /=; rewrite /sem_sop2 /sem_sop1 /=; -have! := (is_wconstP gd s h2); +have! := (is_wconstP wdb gd s h2); t_xrbindP => ? k1 k2 ? k3 ? k4 ? k5 ? k6 ?; clarify. - by rewrite wrepr_unsigned GRing.mulr0;eauto. - case: (to_wordI k5) => {k5} sz' [w] [? /truncate_word_uincl ?]; subst. @@ -293,8 +294,8 @@ Proof. t_xrbindP => v1 k1 v2 k2 w1' /to_wordI [sz1 [w1 [? hle1]]] w2' /to_wordI [sz2 [w2 [? hle2]]] ? /= [] ? ?;subst. eexists; split; first reflexivity. - have! := (is_wconstP gd s h1); rewrite k1 /= hle1 => -[?]; subst. - have! := (is_wconstP gd s h2); rewrite k2 /= hle2 => -[?]; subst. + have! := (is_wconstP wdb gd s h1); rewrite k1 /= hle1 => -[?]; subst. + have! := (is_wconstP wdb gd s h2); rewrite k2 /= hle2 => -[?]; subst. done. Qed. @@ -337,8 +338,8 @@ Proof. t_xrbindP => v1 k1 v2 k2 w1' /to_wordI [sz1 [w1 [? hle1]]] w2' /to_wordI [sz2 [w2 [? hle2]]] ? /= [] ? ?;subst. eexists; split; first reflexivity. - have! := (is_wconstP gd s h1); rewrite k1 /= hle1 => -[?]; subst. - have! := (is_wconstP gd s h2); rewrite k2 /= hle2 => -[?]; subst. + have! := (is_wconstP wdb gd s h1); rewrite k1 /= hle1 => -[?]; subst. + have! := (is_wconstP wdb gd s h2); rewrite k2 /= hle2 => -[?]; subst. done. Qed. @@ -348,7 +349,7 @@ Lemma is_cmp_constP s ty e z : | Cmp_int => e = Pconst z | Cmp_w sg sz => exists2 x, - sem_pexpr gd s e = ok x & + sem_pexpr wdb gd s e = ok x & exists2 w, to_word sz x = ok w & match sg with @@ -359,7 +360,7 @@ Lemma is_cmp_constP s ty e z : Proof. case: ty => /=. - by case: is_constP => // ? /Some_inj <-. - move => sg sz /oseq.obindI [] w [] /(is_wconstP gd s). + move => sg sz /oseq.obindI [] w [] /(is_wconstP wdb gd s). t_xrbindP => v -> ok_w [<-{z}]. exists v => //. exists w => //. @@ -473,7 +474,7 @@ Qed. Lemma app_sopnP T0 ts o es x s : @app_sopn T0 ts o es = ok x -> - sem_pexprs gd s es >>= values.app_sopn ts o = ok x. + sem_pexprs wdb gd s es >>= values.app_sopn ts o = ok x. Proof. elim: ts es o => /= [ | t ts ih ]. + by case=> // _ -> [<-]. @@ -485,7 +486,7 @@ Proof. Qed. Lemma s_opNP op s es : - sem_pexpr gd s (s_opN op es) = sem_pexpr gd s (PappN op es). + sem_pexpr wdb gd s (s_opN op es) = sem_pexpr wdb gd s (PappN op es). Proof. Opaque app_sopn values.app_sopn. @@ -511,15 +512,15 @@ Definition vconst c := | Cword sz z => Vword z end. -Definition valid_cpm (vm: vmap) (m:cpm) := - forall x n, Mvar.get m x = Some n -> get_var vm x = ok (vconst n). +Definition valid_cpm (vm: Vm.t) (m:cpm) := + forall x n, Mvar.get m x = Some n -> vm.[x] = vconst n. Lemma valid_cpm_empty vm : valid_cpm vm empty_cpm. Proof. move=> x n. by rewrite Mvar.get0. Qed. Definition eqoks e1 e2 st := - ∀ vs, sem_pexprs gd st e1 = ok vs → exists2 vs', sem_pexprs gd st e2 = ok vs' & List.Forall2 value_uincl vs vs'. + ∀ vs, sem_pexprs wdb gd st e1 = ok vs → exists2 vs', sem_pexprs wdb gd st e2 = ok vs' & List.Forall2 value_uincl vs vs'. Section CONST_PROP_EP. Context (s:estate) m (Hvalid: valid_cpm (evm s) m). @@ -533,12 +534,13 @@ Section CONST_PROP_EP. - by move => ? [<-]; exists [::]. - move => e rec es ih ?; rewrite /sem_pexprs /=. apply: rbindP => v /rec [v'] [->] hu. - by apply: rbindP => vs /ih{ih}; rewrite -/(sem_pexprs gd s _) => - [vs'] -> hrec [<-] /=; eauto. + by apply: rbindP => vs /ih{ih}; rewrite -/(sem_pexprs wdb gd s _) => - [vs'] -> hrec [<-] /=; eauto. - move => [x []] v; rewrite /= /get_gvar /=; last by eauto. move: Hvalid => /(_ x). case: Mvar.get => [n /(_ _ erefl)| _ /= ]; last by rewrite /= /get_gvar /=;eauto. - by case: n => [ b | n | sz w ] /= -> [<-]; rewrite /sem_sop1 /= ?wrepr_unsigned; - eexists;(split;first reflexivity) => /=. + move=> hx /get_varP; rewrite hx => -[-> _ _] {hx}. + by case: n => [ b | n | sz w ]; rewrite /sem_sop1 /= ?wrepr_unsigned; + eexists;(split;first reflexivity) => //=; rewrite wrepr_unsigned. - move => aa sz x e He v. apply:on_arr_gvarP; rewrite /on_arr_var => n t ? -> /=. t_xrbindP => z w /(He _) [v'] [->] /[swap] /to_intI -> /value_uinclE ->. @@ -565,7 +567,7 @@ Section CONST_PROP_EP. by apply: vuincl_sem_sop2 h. - move => op es ih v. t_xrbindP => vs /ih{ih} [] vs' ih /vuincl_sem_opN h/h{h} [] v' ok_v' h. - by rewrite s_opNP /= -/(sem_pexprs _ _) ih /= ok_v'; eauto. + by rewrite s_opNP /= -/(sem_pexprs _ _ _) ih /= ok_v'; eauto. move => t e He e1 He1 e2 He2 v. t_xrbindP => b ve /He/= [] ve' [] hse /[swap] /to_boolI -> /value_uinclE ?; subst. move=> ve1 vte1 /He1 []ve1' [] hse1 hue1 /(value_uincl_truncate hue1) [] ? /dup[] ht1 /truncate_value_uincl ht1' hu1. @@ -584,51 +586,44 @@ Definition const_prop_esP es s m h := (@const_prop_e_esP s m h).2 es. Lemma remove_cpm1P x v m s1 s1' : - write_var x v s1 = ok s1' -> + write_var wdb x v s1 = ok s1' -> valid_cpm (evm s1) m -> valid_cpm (evm s1') (Mvar.remove m x). Proof. - move=> Hw Hv z n;rewrite Mvar.removeP;case: ifPn => //= ? /Hv. - move: Hw;apply: rbindP => vm;apply: on_vuP => [ w ? <- [<-] | ]. - + by rewrite /get_var /= Fv.setP_neq. - by case: ifP => //= _ ? [<-] [<-] /=;rewrite /get_var /= Fv.setP_neq. + move=> Hw Hv z n;rewrite Mvar.removeP;case: ifPn => //= hne /Hv. + by move/write_varP: Hw => [-> _ _ /=]; rewrite Vm.setP_neq. Qed. Lemma add_cpmP s1 s1' m x e tag ty v1 v v' : - sem_pexpr gd s1 e = ok v1 -> + wdb -> + sem_pexpr wdb gd s1 e = ok v1 -> value_uincl v v1 -> truncate_val ty v = ok v' -> - write_lval gd x v' s1 = ok s1' -> + write_lval wdb gd x v' s1 = ok s1' -> valid_cpm (evm s1') m -> valid_cpm (evm s1') (add_cpm m x tag ty e). Proof. - rewrite /add_cpm;case: x => //= x He. + rewrite /add_cpm;case: x => //= x hwdb He. case: tag => //. case: e He => // [n | b | [] // sz [] //= q ] [<-]. + case: v => //= ?; last by move=> ?? /truncate_valE. - move=> -> /truncate_valE [_ ->]. - case: x => -[] [] //= xn vi [] <- /= Hv z /= n0. - have := Hv z n0. - case: ({| vtype := sint; vname := xn |} =P z). - + move=> <- /=;rewrite Mvar.setP_eq=> ? -[] <-;by rewrite /get_var Fv.setP_eq. - by move=> /eqP Hneq;rewrite Mvar.setP_neq. + move=> -> /truncate_valE [_ ->] hw hv z n0. + rewrite Mvar.setP /=; case: eqP => [<- [<-]| hne]; last by apply hv. + rewrite hwdb in hw *. + by have [_ /vm_truncate_valE [hty ->] /get_varP [<-??]] := write_get_varP_eq hw. + case: v => //= ?;last by move=> ??/truncate_valE. - move=> -> /truncate_valE [_ ->]. - case: x => -[] [] //= xn vi [] <- /= Hv z /= n0. - have := Hv z n0. - case: ({| vtype := sbool; vname := xn |} =P z). - + move=> <- /=;rewrite Mvar.setP_eq=> ? -[] <-;by rewrite /get_var Fv.setP_eq. - by move=> /eqP Hneq;rewrite Mvar.setP_neq. + move=> -> /truncate_valE [_ ->] hw hv z n0. + rewrite Mvar.setP /=; case: eqP => [<- [<-]| hne]; last by apply hv. + rewrite hwdb in hw *. + by have [_ /vm_truncate_valE [hty ->] /get_varP [<-??]] := write_get_varP_eq hw. case: v => //= s ;last by move=> ??/truncate_valE. move=> w /andP[] Ule /eqP -> /truncate_valE [szw [ww [-> /truncate_wordP[hle ->] ->]]] /=. rewrite !(zero_extend_wrepr _ Ule, zero_extend_wrepr _ (cmp_le_trans hle Ule), zero_extend_wrepr _ hle). - case: x => -[] [] //= szx xn vi; apply: rbindP => vm. - apply: set_varP => //= w' [<-] <- [<-] /= Hv z /= n. - have := Hv z n. - case: ({| vtype := sword szx; vname := xn |} =P z). - + move=> <- /=; rewrite Mvar.setP_eq=> ? -[] <-; rewrite /get_var Fv.setP_eq /=. - by f_equal; case: Sumbool.sumbool_of_bool => h;rewrite h. - by move=> /eqP Hneq;rewrite Mvar.setP_neq. + move=> hw hv z n. + rewrite Mvar.setP /=; case: eqP => [<- [<-]| hne]; last by apply hv. + rewrite hwdb in hw *. + have [_ /vm_truncate_valE [ws' [-> _ -> /=]] /get_varP [<-]] := write_get_varP_eq hw. + by case: ifPn. Qed. Lemma merge_cpmP rho m1 m2 : @@ -643,9 +638,9 @@ Qed. Lemma const_prop_rvP s1 s2 m x v: valid_cpm (evm s1) m -> - write_lval gd x v s1 = Ok error s2 -> + write_lval wdb gd x v s1 = Ok error s2 -> valid_cpm (evm s2) (const_prop_rv m x).1 /\ - write_lval gd (const_prop_rv m x).2 v s1 = ok s2. + write_lval wdb gd (const_prop_rv m x).2 v s1 = ok s2. Proof. case:x => [ii t | x | sz x p | aa sz x p | aa sz len x p] /= Hv; t_xrbindP. + by move=> H; have [??]:= write_noneP H; subst s2. @@ -661,9 +656,9 @@ Qed. Lemma const_prop_rvsP s1 s2 m x v: valid_cpm (evm s1) m -> - write_lvals gd s1 x v = Ok error s2 -> + write_lvals wdb gd s1 x v = Ok error s2 -> valid_cpm (evm s2) (const_prop_rvs m x).1 /\ - write_lvals gd s1 (const_prop_rvs m x).2 v = ok s2. + write_lvals wdb gd s1 (const_prop_rvs m x).2 v = ok s2. Proof. elim: x v m s1 s2 => [ | x xs Hrec] [ | v vs] //= m s1 s2 Hm. + by move=> [<-]. @@ -703,16 +698,16 @@ Lemma get_remove_cpm m xs x n: Proof. by move=> H;have := remove_cpm_spec m xs x;rewrite H. Qed. Lemma valid_cpm_rm rho1 rho2 xs m: - rho1 = rho2 [\ xs] -> + rho1 =[\ xs] rho2 -> valid_cpm rho1 m -> valid_cpm rho2 (remove_cpm m xs). Proof. move=> Hrho Hval x nx /get_remove_cpm [] Hm Hin. - rewrite /get_var -Hrho //;apply (Hval _ _ Hm). + rewrite -Hrho //; apply (Hval _ _ Hm). Qed. Lemma remove_cpmP s s' m x v: - write_lval gd x v s = ok s' -> + write_lval wdb gd x v s = ok s' -> valid_cpm (evm s) m -> valid_cpm (evm s') (remove_cpm m (vrv x)). Proof. move=> Hw Hv; apply: (valid_cpm_rm _ Hv);eapply vrvP;eauto. Qed. @@ -1009,7 +1004,7 @@ Section PROOF. have [v1 [H U]] := const_prop_eP Hm He. have [] := const_prop_rvP Hm Hw. case: const_prop_rv => m' x' /= Hm' Hw';split. - + by eapply add_cpmP;eauto. + + by apply: add_cpmP H U htr Hw' Hm'. move=> vm1 hvm1. have [v1' hv1' uv1']:= sem_pexpr_uincl hvm1 H. have [v2 htr2 hv']:= value_uincl_truncate U htr. @@ -1062,7 +1057,7 @@ Section PROOF. case: const_prop_rvs => m' rvs' /= h1 h2; split => // vm1 hvm1. have [vs2 hs u2]:= sem_pexprs_uincl hvm1 Hes'. have [vs' ho' Us']:= exec_syscallP ho (Forall2_trans value_uincl_trans Us u2). - have /(_ _ hvm1) [vm2 hw' U]:= writes_uincl _ Us' h2. + have /(_ _ hvm1) [vm2 hw' U] := writes_uincl _ Us' h2. exists vm2; split => //=; apply sem_seq1; constructor; econstructor; eauto. Qed. @@ -1103,10 +1098,10 @@ Section PROOF. set ww := write_i _;set m' := remove_cpm _ _. case Heq1: const_prop => [m'' c0] /=. case Heq2: const_prop => [m_ c0'] /=. - have eq1_1 : evm s1 = evm s1 [\ww] by done. + have eq1_1 : evm s1 =[\ww] evm s1 by done. have /Hc:= valid_cpm_rm eq1_1 Hm;rewrite -/m' Heq1 /= => -[Hm'' Hc0]. have := Hc' _ Hm'';rewrite Heq2 /= => -[_ Hc0']. - have eq1_3 : evm s1 = evm s3 [\ww]. + have eq1_3 : evm s1 =[\ww] evm s3. + rewrite /ww write_i_while -write_c_app;apply: writeP. by apply: sem_app;eauto. have /Hw -/(_ ii) /=:= valid_cpm_rm eq1_3 Hm. @@ -1131,7 +1126,7 @@ Section PROOF. have [vm2 [hc0 hvm2]]:= Hc0 _ hvm1. have [vm3 [hc0' hvm3]]:= Hc0' _ hvm2. have H : forall e0, - sem_pexpr gd s2 e0 = ok (Vbool true) -> + sem_pexpr true gd s2 e0 = ok (Vbool true) -> (exists vm2, sem p' ev (with_vm s3 vm3) [:: MkI ii (Cwhile a c0 e0 c0')] (with_vm s4 vm2) ∧ vm_uincl (evm s4) vm2) -> @@ -1152,7 +1147,7 @@ Section PROOF. set ww := write_i _;set m' := remove_cpm _ _. case Heq1: const_prop => [m'' c0] /=. case Heq2: const_prop => [m_ c0'] /=. - have eq1_1 : evm s1 = evm s1 [\ww] by done. + have eq1_1 : evm s1 =[\ww] evm s1 by done. have /Hc:= valid_cpm_rm eq1_1 Hm;rewrite -/m' Heq1 /= => -[Hm'' Hc0];split => //. have [v' [Hv' /=]]:= const_prop_eP Hm'' He. case: v' Hv' => // ? Hv' ? ;subst. @@ -1200,7 +1195,7 @@ Section PROOF. have /(Hf _ Heqm) Hc'': valid_cpm (evm s2) m. + have -> := valid_cpm_m (refl_equal (evm s2)) Heqm. apply: valid_cpm_rm Hm'=> z Hz;apply: (writeP Hsemc);SvD.fsetdec. - have /(_ _ (value_uincl_refl _))[vm1' hw hvm1']:= write_var_uincl hvm1 _ Hw. + have /(_ _ _ (value_uincl_refl _)) [vm1' hw hvm1'] := write_var_uincl hvm1 _ Hw. have [vm2 [hc' /Hc'' [vm3 [hfor U]]]]:= Hc' _ hvm1';exists vm3;split => //. by apply: EForOne hc' hfor. Qed. @@ -1225,13 +1220,13 @@ Section PROOF. move => scs1 m1 sc2 m2 fn f vargs vargs' s0 s1 s2 vres vres'. case: f=> fi ftin fparams fc ftout fres fex /= Hget Hargs Hi Hw _ Hc Hres Hfull Hscs Hfi. generalize (get_map_prog const_prop_fun p fn); rewrite Hget /=. - have [] := Hc _ (valid_cpm_empty (evm s1)). - case: const_prop => m c' /= hcpm hc' hget vargs1 hargs'. - have [vargs1' htr hu1]:= mapM2_truncate_val Hargs hargs'. + have : valid_cpm (evm s1) empty_cpm by move=> x n;rewrite Mvar.get0. + move=> /Hc [];case: const_prop => m c' /= hcpm hc' hget vargs1 hargs'. + have [vargs1' htr hu1]:= mapM2_dc_truncate_val Hargs hargs'. have [vm3 /= hw hu3]:= write_vars_uincl (vm_uincl_refl _) hu1 Hw. have [vm4 /= []hc hu4]:= hc' _ hu3. have [vres1 hvres1 hu5]:= get_vars_uincl hu4 Hres. - have [vres1' ??]:= mapM2_truncate_val Hfull hu5. + have [vres1' ??]:= mapM2_dc_truncate_val Hfull hu5. exists vres1';split => //. econstructor;eauto => /=. by move: hw;rewrite with_vm_same. diff --git a/proofs/compiler/dead_calls_proof.v b/proofs/compiler/dead_calls_proof.v index eea03c2cc..4c53c2c6d 100644 --- a/proofs/compiler/dead_calls_proof.v +++ b/proofs/compiler/dead_calls_proof.v @@ -11,6 +11,8 @@ Unset Printing Implicit Defensive. Section WITH_PARAMS. Context + {wsw : WithSubWord} + {dc:DirectCall} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} diff --git a/proofs/compiler/dead_code.v b/proofs/compiler/dead_code.v index 86f5804ac..cbc2cece9 100644 --- a/proofs/compiler/dead_code.v +++ b/proofs/compiler/dead_code.v @@ -6,7 +6,6 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope vmap. Local Open Scope seq_scope. Module Import E. diff --git a/proofs/compiler/dead_code_proof.v b/proofs/compiler/dead_code_proof.v index 0d0237710..121ca443e 100644 --- a/proofs/compiler/dead_code_proof.v +++ b/proofs/compiler/dead_code_proof.v @@ -8,12 +8,13 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope vmap. Local Open Scope seq_scope. Section WITH_PARAMS. Context + {wsw : WithSubWord} + {dc:DirectCall} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} @@ -34,8 +35,6 @@ Context Section PROOF. - Hypothesis wf_init: wf_init sCP. - Variables (do_nop : bool) (onfun : funname -> option (seq bool)) (p p' : prog) (ev:extra_val_t). Notation gd := (p_globs p). @@ -51,7 +50,6 @@ Section PROOF. forall ii s2, match dead_code_i is_move_op do_nop onfun (MkI ii i) s2 with | Ok (s1, c') => - wf_vm s.(evm) -> forall vm1', s.(evm) <=[s1] vm1' -> exists vm2', s'.(evm) <=[s2] vm2' /\ sem p' ev (with_vm s vm1') c' (with_vm s' vm2') @@ -62,7 +60,6 @@ Section PROOF. forall s2, match dead_code_i is_move_op do_nop onfun i s2 with | Ok (s1, c') => - wf_vm s.(evm) -> forall vm1', s.(evm) <=[s1] vm1' -> exists vm2', s'.(evm) <=[s2] vm2' /\ sem p' ev (with_vm s vm1') c' (with_vm s' vm2') @@ -73,7 +70,6 @@ Section PROOF. forall s2, match dead_code_c (dead_code_i is_move_op do_nop onfun) c s2 with | Ok (s1, c') => - wf_vm s.(evm) -> forall vm1', s.(evm) <=[s1] vm1' -> exists vm2', s'.(evm) <=[s2] vm2' /\ sem p' ev (with_vm s vm1') c' (with_vm s' vm2') @@ -85,7 +81,6 @@ Section PROOF. match dead_code_c (dead_code_i is_move_op do_nop onfun) c s2 with | Ok (s1, c') => Sv.Subset (Sv.union (read_rv (Lvar i)) (Sv.diff s1 (vrv (Lvar i)))) s2 -> - wf_vm s.(evm) -> forall vm1', s.(evm) <=[s2] vm1' -> exists vm2', s'.(evm) <=[s2] vm2' /\ sem_for p' ev i vs (with_vm s vm1') c' (with_vm s' vm2') @@ -99,7 +94,7 @@ Section PROOF. List.Forall2 value_uincl (fn_keep_only onfun fn vres) vres'. Local Lemma Hskip : sem_Ind_nil Pc. - Proof. by move=> s1 s2 Hwf vm' Hvm; exists vm'; split=> //; constructor. Qed. + Proof. by move=> s1 s2 vm' Hvm; exists vm'; split=> //; constructor. Qed. Local Lemma Hcons : sem_Ind_cons p ev Pc Pi. Proof. @@ -107,9 +102,8 @@ Section PROOF. have := Hc sv3. case: (dead_code_c (dead_code_i is_move_op do_nop onfun) c sv3)=> [[sv2 c']|//] Hc' /=. have := Hi sv2. - case: (dead_code_i is_move_op do_nop onfun i sv2)=> [[sv1 i']|] //= Hi' Hwf vm1' /(Hi' Hwf). - have Hwf2 := wf_sem_I H Hwf. - move=> [vm2' [Heq2 Hsi']];case: (Hc' Hwf2 _ Heq2) => [vm3' [Heq3 Hsc']]. + case: (dead_code_i is_move_op do_nop onfun i sv2)=> [[sv1 i']|] //= Hi' vm1' /Hi'. + move=> [vm2' [Heq2 Hsi']];case: (Hc' _ Heq2) => [vm3' [Heq3 Hsc']]. exists vm3';split=> //. by apply: sem_app Hsi' Hsc'. Qed. @@ -125,31 +119,30 @@ Section PROOF. Qed. Local Lemma Hassgn_aux ii s1 s2 v v' x tag ty e s: - sem_pexpr gd s1 e = ok v -> + sem_pexpr true gd s1 e = ok v -> truncate_val ty v = ok v' -> - write_lval gd x v' s1 = ok s2 -> - wf_vm (evm s1) → - ∀ vm1' : vmap, + write_lval true gd x v' s1 = ok s2 -> + ∀ vm1', (evm s1) <=[read_rv_rec (read_e_rec (Sv.diff s (write_i (Cassgn x tag ty e))) e) x] vm1' → - ∃ vm2' : vmap, (evm s2) <=[s] vm2' + ∃ vm2', (evm s2) <=[s] vm2' ∧ sem p' ev (with_vm s1 vm1') [:: MkI ii (Cassgn x tag ty e)] (with_vm s2 vm2'). Proof. - move=> Hv Hv' Hw Hwf vm1' Hvm. + move=> Hv Hv' Hw vm1' Hvm. rewrite write_i_assgn in Hvm. move: Hvm; rewrite read_rvE read_eE=> Hvm. rewrite (surj_estate s1) in Hv. - have h : (evm s1) <=[read_e e] vm1' by apply: vmap_uincl_onI Hvm;SvD.fsetdec. + have h : (evm s1) <=[read_e e] vm1' by apply: uincl_onI Hvm;SvD.fsetdec. have [v'' Hv'' Hveq] := sem_pexpr_uincl_on' h Hv. have Huincl := truncate_value_uincl Hv'. have [v''' Ht Hv''']:= value_uincl_truncate Hveq Hv'. have [| vm2' Hvm2 Hw2]:= write_lval_uincl_on _ Hv''' Hw Hvm; first by SvD.fsetdec. - exists vm2'; split; first by apply: vmap_uincl_onI Hvm2; SvD.fsetdec. + exists vm2'; split; first by apply: uincl_onI Hvm2; SvD.fsetdec. apply sem_seq1; constructor. apply Eassgn with v'' v''';rewrite -?eq_globs. rewrite /with_vm /=. apply Hv''. apply Ht. apply Hw2. Qed. - Local Lemma Hwrite_disj s1 s2 s x v: - write_lval gd x v s1 = ok s2 -> + Local Lemma Hwrite_disj wdb s1 s2 s x v: + write_lval wdb gd x v s1 = ok s2 -> disjoint s (vrv x) -> ~~ lv_write_mem x -> [/\ escs s1 = escs s2, evm s1 =[s] evm s2 & emem s1 = emem s2]. @@ -158,8 +151,8 @@ Section PROOF. by apply: disjoint_eq_on Hdisj Hw. Qed. - Local Lemma Hwrites_disj s1 s2 s x v: - write_lvals gd s1 x v = ok s2 -> + Local Lemma Hwrites_disj wdb s1 s2 s x v: + write_lvals wdb gd s1 x v = ok s2 -> disjoint s (vrvs x) -> ~~ has lv_write_mem x -> [/\ escs s1 = escs s2, evm s1 =[s] evm s2 & emem s1 = emem s2]. @@ -181,32 +174,20 @@ Section PROOF. case: ifPn=> _ /=; last by apply: Hassgn_aux Hv htr Hw. case: ifPn=> /= [ | _]; last by apply: Hassgn_aux Hv htr Hw. move=> /orP []. - + rewrite write_i_assgn => /andP [Hdisj Hwmem] Hwf vm1' Hvm. + + rewrite write_i_assgn => /andP [Hdisj Hwmem] vm1' Hvm. have /= [ <- Hvm1 <-]:= Hwrite_disj Hw Hdisj Hwmem. rewrite /with_vm /=; exists vm1' => /=;split; last by constructor. - by apply: vmap_uincl_onT Hvm => z Hin; rewrite (Hvm1 z). - move=> /andP [_ Hnop] /= Hwf vm1' Hvm. + by apply: uincl_onT Hvm => z Hin; rewrite (Hvm1 z). + move=> /andP [_ Hnop] /= vm1' Hvm. have [-> -> Hs] : [/\ scs1 = scs2, m1 = m2 & vm2 <=[s] vm1]. + move: (check_nop_spec Hnop)=> {Hnop} [x0 [i1 [i2 [Hx He]]]];subst x e. - case: x0 Hv Hw => ty'' xn0 /= Hv Hw. - have Hv': value_uincl v' v. - + by apply: on_vuP Hv=> //= pty'' /= Ht pty; subst; apply (truncate_value_uincl htr). - move: Hw; rewrite /= /write_var /set_var /=; t_xrbindP=> vm2'. - apply: on_vuP=> /=. - + move=>v'' hv'' <- <- <- <- /=; split=> //= => z Hin. - case: ({| vtype := ty''; vname := xn0 |} =P z)=> //=. - + move=> Hz; subst z; rewrite Fv.setP_eq; move: Hv; rewrite /get_gvar /= /get_var /=. - apply: on_vuP=> //= v1 -> /= hv1; subst; have [v1' [/= h1 h2]]:= pof_val_uincl Hv' hv''. - by rewrite pof_val_pto_val in h1; case: h1=> ->. - by move=> Hz; rewrite Fv.setP_neq //; apply /eqP. - move=> Hz; case: ifP=> //= Hb [] <- <- <- <- /=; split=> //= z Hin. - case: ({| vtype := ty''; vname := xn0 |} =P z)=> //=. - + move=> Hz'; subst z; rewrite Fv.setP_eq; move: Hv; rewrite /get_gvar /= /get_var /=. - apply: on_vuP=> //= v1 -> /= hv1; subst; move/is_sboolP : Hb => Hb; subst. - by have /= h1 := pof_val_undef Hv' Hz. - by move=> Hz'; rewrite Fv.setP_neq //; apply /eqP. + have Hv':= truncate_value_uincl htr. + move/write_varP: Hw => [[-> -> ->] hdb htr1]; split => //. + apply uincl_on_set_l => //= Hin. + move: Hv; rewrite /= /get_gvar /= /get_var; t_xrbindP => _ ->. + by apply: value_uincl_trans (vm_truncate_value_uincl htr1) Hv'. eexists; split; last by exact: Eskip. - by apply: vmap_uincl_onT=> //; apply: vmap_uincl_onT Hs Hvm. + by apply: uincl_onT=> //; apply: uincl_onT Hs Hvm. Qed. Lemma check_nop_opn_spec (xs:lvals) (o:sopn) (es:pexprs): check_nop_opn is_move_op xs o es -> @@ -223,22 +204,22 @@ Section PROOF. Qed. Local Lemma Hopn_aux s0 ii xs t o es v vs s1 s2 : - sem_pexprs gd s1 es = ok vs -> + sem_pexprs true gd s1 es = ok vs -> exec_sopn o vs = ok v -> - write_lvals gd s1 xs v = ok s2 -> - wf_vm (evm s1) → ∀ vm1' : vmap, + write_lvals true gd s1 xs v = ok s2 -> + ∀ vm1', evm s1 <=[read_es_rec (read_rvs_rec (Sv.diff s0 (vrvs xs)) xs) es] vm1' → - ∃ vm2' : vmap, evm s2 <=[s0] vm2' ∧ + ∃ vm2', evm s2 <=[s0] vm2' ∧ sem p' ev (with_vm s1 vm1') [:: MkI ii (Copn xs t o es)] (with_vm s2 vm2'). Proof. - case: s1 => scs1 m1 vm1 /= Hexpr Hopn Hw Hwf vm1' Hvm. + case: s1 => scs1 m1 vm1 /= Hexpr Hopn Hw vm1' Hvm. have [ vs' Hexpr' vs_vs' ] := sem_pexprs_uincl_on' Hvm Hexpr. have [ v' Hopn' v_v' ] := vuincl_exec_opn vs_vs' Hopn. rewrite read_esE read_rvsE in Hvm. have [ | vm2 Hvm2 Hw' ] := write_lvals_uincl_on _ v_v' Hw Hvm; first by clear; SvD.fsetdec. exists vm2; split; - first by apply: vmap_uincl_onI Hvm2; clear; SvD.fsetdec. + first by apply: uincl_onI Hvm2; clear; SvD.fsetdec. apply: sem_seq1; do 2 constructor. by rewrite /sem_sopn /with_vm /= -eq_globs Hexpr' /= Hopn'. Qed. @@ -250,48 +231,36 @@ Section PROOF. rewrite /Pi_r /= => ii s0. case: ifPn => _ /=; last by apply: Hopn_aux Hexpr Hopn Hw. case:ifPn => [ | _] /=. - + move=> /andP [Hdisj Hnh] Hwf vm1' Heq;exists vm1'. - case: s1 s2 Hw Hexpr Hwf Heq => scs1 m1 vm1 [scs2 m2 vm2] Hw _ Hwf /= Heq. + + move=> /andP [Hdisj Hnh] vm1' Heq;exists vm1'. + case: s1 s2 Hw Hexpr Heq => scs1 m1 vm1 [scs2 m2 vm2] Hw _ /= Heq. have [/= -> H ->]:= Hwrites_disj Hw Hdisj Hnh; split; last by constructor. - apply: vmap_uincl_onT Heq. move=> z Hin. rewrite (H z). done. done. + apply: uincl_onT Heq. move=> z Hin. rewrite (H z). done. done. case:ifPn => [ | _ /=]; last by apply: Hopn_aux Hexpr Hopn Hw. move=> /check_nop_opn_spec [x [i1 [op [i2 [? ? ho ?]]]]]; - subst xs o es=> /= Hwf vm1' Hvm. + subst xs o es=> /= vm1' Hvm. rewrite (surj_estate s1) (surj_estate s2) /with_vm /=. have [ -> -> Hs ]: [/\ escs s1 = escs s2, emem s1 = emem s2 & evm s2 <=[s0] evm s1]. + case: x0 Hexpr Hopn => [ | vx] /=; first by t_xrbindP. case; t_xrbindP => // vx' hgetx ? hs; subst vx'. have Hvs := is_move_opP ho hs. - move: Hw; rewrite /= /write_var /set_var /=. case: v hs Hvs=> //= v vs hs Hvs. - t_xrbindP=> s2' vm3. - case: vs hs Hvs=> //= hs /List_Forall2_inv[] Hv _. - apply: on_vuP=> /=. - + move=> ps //= hp <- //= <- //= /ok_inj <- /=; split => //. - move=> z Hin. case: (x =P z)=> //=. - + move=> Hz. subst z. rewrite Fv.setP_eq. move: hgetx. rewrite /get_gvar /= /get_var /=. - apply: on_vuP=> //= v1 -> /= hv1; subst. - rewrite /pval_uincl. apply: value_uincl_pof_val. by rewrite -hp /=. - by rewrite /pto_val. - move=> Hz. rewrite Fv.setP_neq //. by apply /eqP. - move=> _; case: ifP=> //= Hb [] <- <- [<-]; split=> //= z Hin. - case: (x =P z)=> //=. - + move=> Hz'; subst z; rewrite Fv.setP_eq; move: hgetx; rewrite /get_gvar /= /get_var /=. - apply: on_vuP=> //= v1 -> _. - by case: (x) Hb v1 => ty xn /= /is_sboolP -> v1. - by move=> Hz'; rewrite Fv.setP_neq //; apply /eqP. - eexists; split; last exact: Eskip. by apply: vmap_uincl_onT Hvm. + move: Hw; case: v hs Hvs=> //=; t_xrbindP => v []// hs /List_Forall2_inv[] Hv _. + move=> s2' /write_varP [-> _ htr1] [<-]; split => //. + apply uincl_on_set_l => //= Hin. + move: hgetx; rewrite /= /get_gvar /= /get_var; t_xrbindP => _ ->. + apply: value_uincl_trans (vm_truncate_value_uincl htr1) Hv. + eexists; split; last exact: Eskip. by apply: uincl_onT Hvm. Qed. Local Lemma Hsyscall : sem_Ind_syscall p Pi_r. Proof. - move=> s1 scs m s2 o xs es ves vs hes ho hw ii X /= hwf vm1. + move=> s1 scs m s2 o xs es ves vs hes ho hw ii X /= vm1. rewrite read_esE read_rvsE => hvm1. have [| ves' hes' ues]:= sem_pexprs_uincl_on (vm2:= vm1) _ hes. - + by apply: vmap_uincl_onI hvm1; SvD.fsetdec. + + by apply: uincl_onI hvm1; SvD.fsetdec. have [vs' ho' uvs]:= exec_syscallP ho ues. have [| vm2 hsub' hw']:= write_lvals_uincl_on _ uvs hw hvm1; first by SvD.fsetdec. exists vm2; split. - + by apply: vmap_uincl_onI hsub'; SvD.fsetdec. + + by apply: uincl_onI hsub'; SvD.fsetdec. by apply sem_seq1; constructor; econstructor; eauto; rewrite -eq_globs. Qed. @@ -299,10 +268,10 @@ Section PROOF. Proof. move=> s1 s2 e c1 c2 Hval Hp Hc ii sv0 /=. case Heq: (dead_code_c (dead_code_i is_move_op do_nop onfun) c1 sv0)=> [[sv1 sc1] /=|//]. - case: (dead_code_c (dead_code_i is_move_op do_nop onfun) c2 sv0)=> [[sv2 sc2] /=|//] Hwf vm1' Hvm. - move: (Hc sv0); rewrite Heq => /(_ Hwf vm1') [|vm2' [Hvm2' Hvm2'1]]. + case: (dead_code_c (dead_code_i is_move_op do_nop onfun) c2 sv0)=> [[sv2 sc2] /=|//] vm1' Hvm. + move: (Hc sv0); rewrite Heq => /(_ vm1') [|vm2' [Hvm2' Hvm2'1]]. move: Hvm; rewrite read_eE=> Hvm. - apply: vmap_uincl_onI Hvm;SvD.fsetdec. + apply: uincl_onI Hvm;SvD.fsetdec. rewrite (surj_estate s1) in Hval. have := sem_pexpr_uincl_on' Hvm Hval. move=> [v] Hval' Hv. @@ -317,12 +286,12 @@ Section PROOF. Proof. move=> s1 s2 e c1 c2 Hval Hp Hc ii sv0 /=. case: (dead_code_c (dead_code_i is_move_op do_nop onfun) c1 sv0)=> [[sv1 sc1] /=|//]. - case Heq: (dead_code_c (dead_code_i is_move_op do_nop onfun) c2 sv0)=> [[sv2 sc2] /=|//] Hwf vm1' Hvm. + case Heq: (dead_code_c (dead_code_i is_move_op do_nop onfun) c2 sv0)=> [[sv2 sc2] /=|//] vm1' Hvm. move: (Hc sv0). rewrite Heq. - move=> /(_ Hwf vm1') [|vm2' [Hvm2' Hvm2'1]]. + move=> /(_ vm1') [|vm2' [Hvm2' Hvm2'1]]. move: Hvm; rewrite read_eE=> Hvm. - apply: vmap_uincl_onI Hvm;SvD.fsetdec. + apply: uincl_onI Hvm;SvD.fsetdec. rewrite (surj_estate s1) in Hval. have := sem_pexpr_uincl_on' Hvm Hval. move=> [v] Hval' Hv. @@ -352,24 +321,22 @@ Section PROOF. move=> s1 s2 s3 s4 a c e c' Hsc Hc H Hsc' Hc' Hsw Hw ii /= sv0. set dobody := (X in wloop X). case Hloop: wloop => [[sv1 [c1 c1']] /=|//]. - move: (wloopP Hloop) => [sv2 [sv2' [H1 [H2 H2']]]] Hwf vm1' Hvm. + move: (wloopP Hloop) => [sv2 [sv2' [H1 [H2 H2']]]] vm1' Hvm. apply: rbindP H2 => -[sv3 c2'] Hc2'. set sv4 := read_e_rec _ _ in Hc2'. apply: rbindP => -[ sv5 c2 ] Hc2 x; apply ok_inj in x. repeat (case/xseq.pair_inj: x => ? x; subst). - have := Hc sv4; rewrite Hc2' => /(_ Hwf vm1') [|vm2' [Hvm2'1 Hvm2'2]]. - + by apply: vmap_uincl_onI Hvm;SvD.fsetdec. - have Hwf2 := wf_sem Hsc Hwf. - have := Hc' sv1;rewrite Hc2=> /(_ Hwf2 vm2') [|vm3' [Hvm3'1 Hvm3'2]]. - + by apply: vmap_uincl_onI Hvm2'1;rewrite /sv4 read_eE;SvD.fsetdec. - have Hwf3 := wf_sem Hsc' Hwf2. - have /= := Hw ii sv0;rewrite Hloop /= => /(_ Hwf3 _ Hvm3'1) [vm4' [Hvm4'1 /semE Hvm4'2]]. + have := Hc sv4; rewrite Hc2' => /(_ vm1') [|vm2' [Hvm2'1 Hvm2'2]]. + + by apply: uincl_onI Hvm;SvD.fsetdec. + have := Hc' sv1;rewrite Hc2=> /(_ vm2') [|vm3' [Hvm3'1 Hvm3'2]]. + + by apply: uincl_onI Hvm2'1;rewrite /sv4 read_eE;SvD.fsetdec. + have /= := Hw ii sv0;rewrite Hloop /= => /(_ _ Hvm3'1) [vm4' [Hvm4'1 /semE Hvm4'2]]. exists vm4';split => //. case: Hvm4'2 => si [/sem_IE Hvm4'2 /semE ?]; subst si. apply sem_seq1;constructor. apply: (Ewhile_true Hvm2'2) Hvm3'2 Hvm4'2; rewrite -?eq_globs. have Hvm': evm s2 <=[read_e_rec sv0 e] vm2'. - + by apply: vmap_uincl_onI Hvm2'1; rewrite /sv4 !read_eE; SvD.fsetdec. + + by apply: uincl_onI Hvm2'1; rewrite /sv4 !read_eE; SvD.fsetdec. rewrite (surj_estate s2) in H. have := sem_pexpr_uincl_on' Hvm2'1 H. move=> [v] H' Hv. rewrite /value_uincl in Hv. case: v Hv H'=> //=. @@ -380,20 +347,20 @@ Section PROOF. Proof. move=> s1 s2 a c e c' Hsc Hc H ii sv0 /=. set dobody := (X in wloop X). - case Hloop: wloop => [[sv1 [c1 c1']] /=|//] Hwf vm1' Hvm. + case Hloop: wloop => [[sv1 [c1 c1']] /=|//] vm1' Hvm. move: (wloopP Hloop) => [sv2 [sv2' [H1 [H2 H2']]]]. apply: rbindP H2 => -[sv3 c2'] Hc2. set sv4 := read_e_rec _ _ in Hc2. apply: rbindP => -[sv5 c2] Hc2' x; apply ok_inj in x. repeat (case/xseq.pair_inj: x => ? x; subst). - have := Hc sv4;rewrite Hc2 => /(_ Hwf vm1') [|vm2' [Hvm2'1 Hvm2'2]]. - + by apply: vmap_uincl_onI Hvm. + have := Hc sv4;rewrite Hc2 => /(_ vm1') [|vm2' [Hvm2'1 Hvm2'2]]. + + by apply: uincl_onI Hvm. exists vm2';split. - + apply: vmap_uincl_onI Hvm2'1;rewrite /sv4 read_eE;SvD.fsetdec. + + apply: uincl_onI Hvm2'1;rewrite /sv4 read_eE;SvD.fsetdec. apply sem_seq1;constructor. apply: (Ewhile_false _ _ Hvm2'2); rewrite -?eq_globs. have Hvm': evm s2 <=[read_e_rec sv0 e] vm2'. - + by apply: vmap_uincl_onI Hvm2'1;rewrite /sv4 !read_eE; SvD.fsetdec. + + by apply: uincl_onI Hvm2'1;rewrite /sv4 !read_eE; SvD.fsetdec. rewrite (surj_estate s2) in H. have := sem_pexpr_uincl_on' Hvm2'1 H. move=> [v] H' Hv. rewrite /value_uincl in Hv. case: v Hv H'=> //=. @@ -418,22 +385,22 @@ Section PROOF. Proof. move=> s1 s2 i d lo hi c vlo vhi Hlo Hhi Hc Hfor ii /= sv0. case Hloop: (loop (dead_code_c (dead_code_i is_move_op do_nop onfun) c) ii Loop.nb Sv.empty (Sv.add i Sv.empty) sv0)=> [[sv1 sc1] /=|//]. - move: (loopP Hloop)=> [H1 [sv2 [H2 H2']]] Hwf vm1' Hvm. + move: (loopP Hloop)=> [H1 [sv2 [H2 H2']]] vm1' Hvm. move: Hfor=> /(_ sv1); rewrite H2. - move=> /(_ H2' Hwf vm1') [|vm2' [Hvm2'1 Hvm2'2]]. + move=> /(_ H2' vm1') [|vm2' [Hvm2'1 Hvm2'2]]. move: Hvm; rewrite !read_eE=> Hvm. - + by apply: vmap_uincl_onI Hvm; SvD.fsetdec. + + by apply: uincl_onI Hvm; SvD.fsetdec. rewrite (surj_estate s1) in Hlo. have := sem_pexpr_uincl_on' Hvm Hlo. move=> [v] Hlo' Hv. exists vm2'; split. - + apply: vmap_uincl_onI Hvm2'1; SvD.fsetdec. + + apply: uincl_onI Hvm2'1; SvD.fsetdec. econstructor; constructor;case: v Hv Hlo'=> //= z <- Hlo'; econstructor; rewrite -?eq_globs. apply Hlo'. rewrite (surj_estate s1) in Hhi. + have Hvm': evm s1 <=[read_e_rec Sv.empty hi] vm1'. + move: Hvm; rewrite !read_eE=> Hvm. - by apply: vmap_uincl_onI Hvm; SvD.fsetdec. + by apply: uincl_onI Hvm; SvD.fsetdec. rewrite (surj_estate s1) in Hhi. have := sem_pexpr_uincl_on' Hvm' Hhi. move=> [v] Hhi' Hv. case: v Hv Hhi'=> //= z' <- Hhi'. by apply Hhi'. @@ -443,7 +410,7 @@ Section PROOF. Local Lemma Hfor_nil : sem_Ind_for_nil Pfor. Proof. move=> s i c sv0. - case Heq: (dead_code_c (dead_code_i is_move_op do_nop onfun) c sv0) => [[sv1 sc1]|] //= Hsub Hwf vm1' Hvm. + case Heq: (dead_code_c (dead_code_i is_move_op do_nop onfun) c sv0) => [[sv1 sc1]|] //= Hsub vm1' Hvm. exists vm1'; split=> //. apply: EForDone. Qed. @@ -451,33 +418,31 @@ Section PROOF. Local Lemma Hfor_cons : sem_Ind_for_cons p ev Pc Pfor. Proof. move=> s1 s1' s2 s3 i w ws c Hw Hsc Hc Hsfor Hfor sv0. - case Heq: (dead_code_c (dead_code_i is_move_op do_nop onfun) c sv0) => [[sv1 sc1]|] //= Hsub Hwf vm1' Hvm. + case Heq: (dead_code_c (dead_code_i is_move_op do_nop onfun) c sv0) => [[sv1 sc1]|] //= Hsub vm1' Hvm. have Hv : value_uincl w w. done. - have [vm1''] := write_var_uincl_on' Hv Hw Hvm. move=> Hvm1''1 Hvm1''2 . + have [vm1''] := write_var_uincl_on Hv Hw Hvm. move=> Hvm1''1 Hvm1''2 . move: Hc=> /(_ sv0). rewrite Heq. - have Hwf' := wf_write_var Hwf Hw. - move=> /(_ Hwf' vm1'') [|vm2' [Hvm2'1 Hvm2'2]]. - apply: vmap_uincl_onI Hvm1''1; SvD.fsetdec. + move=> /(_ vm1'') [|vm2' [Hvm2'1 Hvm2'2]]. + apply: uincl_onI Hvm1''2; SvD.fsetdec. move: Hfor=> /(_ sv0). rewrite Heq. - move=> /(_ _ _ vm2') [|||vm3' [Hvm3'1 Hvm3'2]] //. - apply: wf_sem Hsc Hwf'. + move=> /(_ _ vm2') [||vm3' [Hvm3'1 Hvm3'2]] //. exists vm3'; split=> //. econstructor. - exact: Hvm1''2. + exact: Hvm1''1. exact: Hvm2'2. exact: Hvm3'2. Qed. - Lemma write_lvals_keep_only tokeep xs I O xs' s1 s2 vs vs' vm1: + Lemma write_lvals_keep_only wdb tokeep xs I O xs' s1 s2 vs vs' vm1: check_keep_only xs tokeep O = ok (I, xs') -> List.Forall2 value_uincl (keep_only vs tokeep) vs' -> - write_lvals gd s1 xs vs = ok s2 -> + write_lvals wdb gd s1 xs vs = ok s2 -> evm s1 <=[I] vm1 -> - ∃ vm2 : vmap, + ∃ vm2, evm s2 <=[O] vm2 - ∧ write_lvals gd (with_vm s1 vm1) xs' vs' = + ∧ write_lvals wdb gd (with_vm s1 vm1) xs' vs' = ok (with_vm s2 vm2). Proof. elim: tokeep xs xs' I s1 vs vm1 vs'=> [ | b tokeep ih] [ | x xs] //= xs' I s1 [ | v vs] // vm1 vs'. @@ -490,17 +455,17 @@ Section PROOF. + by rewrite read_rvE; SvD.fsetdec. move=> vm1' heq' hw' /=. have [|vm2 [heqO hws']] := ih xs xs1 I1 s1' vs vm1' l' hc H3 hws. - + by apply: vmap_uincl_onI heq'; rewrite read_rvE; SvD.fsetdec. + + by apply: uincl_onI heq'; rewrite read_rvE; SvD.fsetdec. have Hvm : vm_uincl (evm (with_vm s1 vm1)) vm1. done. have [vm3 Hw' Hvm']:= write_uincl Hvm H1 hw'. rewrite Hw' /=. rewrite /with_vm /=. have Hv' : List.Forall2 value_uincl l' l'. by apply List_Forall2_refl. have [vm4 Hws' /= Hvm'']:= writes_uincl Hvm' Hv' hws'. exists vm4;rewrite /=; split=> //=. - apply: (vmap_uincl_onT heqO). move=> z hin. apply: Hvm''. + by apply: (uincl_onT heqO) => z hin; apply: Hvm''. case:andP => //= -[hd hnmem] [??] hv s1' hw hws heqI; subst I1 xs1. have [hscs1 heq1 hmem1]:= Hwrite_disj hw hd hnmem. have [|vm2 [heqO hws']] := ih _ _ _ _ _ vm1 _ hc hv hws. - + apply: vmap_uincl_onT heqI. move=> z Hin. by rewrite (heq1 z). + + apply: uincl_onT heqI. move=> z Hin. by rewrite (heq1 z). by rewrite /with_vm hmem1 hscs1 ; exists vm2. Qed. @@ -508,13 +473,13 @@ Section PROOF. Proof. move=> s1 scs2 m2 s2 ii xs fn args vargs vs Hexpr Hcall Hfun Hw ii' sv0 /=. set sxs := (X in Let sxs := X in _). - case heq: sxs => [ [I xs'] | ] //= => Hwf vm1' Hvm. + case heq: sxs => [ [I xs'] | ] //= => vm1' Hvm. rewrite (surj_estate s1) in Hexpr. - have h : evm s1 <=[read_es_rec I args] vm1' by apply: vmap_uincl_onI Hvm; SvD.fsetdec. + have h : evm s1 <=[read_es_rec I args] vm1' by apply: uincl_onI Hvm; SvD.fsetdec. have [vs' Hexpr' Hv] := sem_pexprs_uincl_on' h Hexpr. rewrite /Pfun in Hfun. move: (Hfun vs' Hv)=> [vs''] [] {Hfun} Hfun Hv'. have [vm2 [Hvm2 /= Hvm2']]: exists vm2, evm s2 <=[sv0] vm2 /\ - write_lvals gd (with_vm (with_scs (with_mem s1 m2) scs2) vm1') xs' vs'' = + write_lvals (~~ direct_call) gd (with_vm (with_scs (with_mem s1 m2) scs2) vm1') xs' vs'' = ok (with_vm s2 vm2); first last. + exists vm2; split => //. econstructor; constructor. @@ -524,7 +489,7 @@ Section PROOF. + apply Hvm2'. move: heq Hv'; rewrite /sxs /fn_keep_only; case: onfun => [tokeep | [??]]. + t_xrbindP=> hc Hv'; apply: (write_lvals_keep_only hc Hv' Hw). - by apply: vmap_uincl_onI Hvm; rewrite read_esE; SvD.fsetdec. + by apply: uincl_onI Hvm; rewrite read_esE; SvD.fsetdec. subst xs' I. have /= Hws := write_lvals_uincl_on _ _ Hw Hvm. have Hsub : Sv.Subset (read_rvs xs) (read_es_rec @@ -534,9 +499,9 @@ Section PROOF. apply List.Forall2_cons. auto. done. move: (Hws vs Hsub Hv''). move=> [vm2] Hvm2 /= Hvm2' Hv'. have [vm3 Hws' Hvm'] := writes_uincl (vm_uincl_refl _) Hv' Hvm2'. exists vm3; split => //. - apply : (@vmap_uincl_onT vm2). - by apply: vmap_uincl_onI Hvm2; rewrite read_esE read_rvsE; SvD.fsetdec. - move=> z Hin. rewrite /with_vm /= in Hvm'. apply (Hvm' z). + apply : (@uincl_onT _ vm2). + by apply: uincl_onI Hvm2; rewrite read_esE read_rvsE; SvD.fsetdec. + by move=> z Hin; rewrite /with_vm /= in Hvm'; apply (Hvm' z). Qed. Local Lemma Hproc : sem_Ind_proc p ev Pc Pfun. @@ -548,23 +513,22 @@ Section PROOF. case: f Hf'1 Hfun htra Hi Hw Hsem Hc Hres Hfull Hscs Hfi => fi ft fp /= c f_tyout res fb Hf'1 Hfun htra Hi Hw Hsem Hc Hres Hfull Hscs Hfi. move: Hf'1; t_xrbindP => -[sv sc] Hd H; subst f'. - move: Hw; rewrite (write_vars_lvals gd) => Hw. + move: Hw; rewrite (write_vars_lvals _ gd) => Hw. have heq : Sv.Equal (read_rvs [seq Lvar i | i <- fp]) Sv.empty. + elim: (fp);first by rewrite read_rvs_nil;SvD.fsetdec. by move=> ?? Hrec; rewrite /= read_rvs_cons /=;SvD.fsetdec. move=> vs Hv. - have [vargs1' htra' hv'] := mapM2_truncate_val htra Hv. - have /(_ sv) [|/= vm1]:= write_lvals_uincl_on _ hv' Hw (vmap_uincl_on_refl _). + have [vargs1' htra' hv'] := mapM2_dc_truncate_val htra Hv. + have/(_ sv (evm s0)) [|//|/=vm1]:= write_lvals_uincl_on _ hv' Hw. + by rewrite heq; SvD.fsetdec. move=> Hvm2'2 Hw'. move: Hc => /(_ (read_es [seq Plvar i | i <- fn_keep_only onfun fn res])); rewrite Hd. - move=> Hc. have: wf_vm (evm s1). - + have Hwf := wf_write_lvals (wf_init Hi wf_vmap0) Hw. by apply Hwf. - have : evm s1 <=[sv] vm1. + by apply: vmap_uincl_onI Hvm2'2;SvD.fsetdec. - move=> Hvm Hwf. move: (Hc Hwf vm1 Hvm). move=> [vm2'] /= [Hvm2'1] Hsem'. - move: Hres; have /= <-:= @sem_pexprs_get_var _ _ _ gd s2 => Hres. + move=> Hc. + have Hvm : evm s1 <=[sv] vm1. + by apply: uincl_onI Hvm2'2;SvD.fsetdec. + move: (Hc vm1 Hvm). move=> [vm2'] /= [Hvm2'1] Hsem'. + move: Hres; have /= <-:= @sem_pexprs_get_var _ _ _ _ _ gd s2 => Hres. case: s2 Hsem Hscs Hfi Hvm2'1 Hsem' Hres Hc=> escs2 emem2 evm2 Hsem Hscs Hfi Hvm2'1 Hsem' Hres Hc. - have Hres' : sem_pexprs gd {| escs := escs2; emem := emem2; evm := evm2 |} + have Hres' : sem_pexprs (~~direct_call) gd {| escs := escs2; emem := emem2; evm := evm2 |} [seq Plvar i | i <- fn_keep_only onfun fn res] = ok (fn_keep_only onfun fn vres). + rewrite /fn_keep_only /=; case: onfun => [tokeep | //]. move: Hres; clear. @@ -572,12 +536,12 @@ Section PROOF. t_xrbindP => v' hv' vres1 /ih{ih}ih <-; case:b => //=. by rewrite hv' /= ih. have [vres1 Hres'' Hvl] := sem_pexprs_uincl_on' Hvm2'1 Hres'. have Hes := sem_pexprs_get_var. - have Hfull' : mapM2 ErrType truncate_val (fn_keep_only onfun fn f_tyout) (fn_keep_only onfun fn vres) = ok (fn_keep_only onfun fn vres'). + have Hfull' : mapM2 ErrType dc_truncate_val (fn_keep_only onfun fn f_tyout) (fn_keep_only onfun fn vres) = ok (fn_keep_only onfun fn vres'). + rewrite /= /fn_keep_only; case: onfun => [tokeep | //]. move:Hfull; clear. elim: tokeep f_tyout vres vres' => // b tokeep ih [| ty f_tyout] /= [ | v vres] //= vres' => [[<-]//|]. t_xrbindP => v' hv'; t_xrbindP => vres1 /ih{} ih <-; case:b => //=. by rewrite hv' /= ih. - have [vres2 {Hfull'} Hfull' Hvl'] := mapM2_truncate_val Hfull' Hvl. + have [vres2 {Hfull'} Hfull' Hvl'] := mapM2_dc_truncate_val Hfull' Hvl. eexists vres2; split=> //=. apply EcallRun with {| f_info := fi; @@ -589,9 +553,9 @@ Section PROOF. f_extra := fb |} vargs1' (with_vm s0 (evm s0)) (with_vm s1 vm1) {| escs := escs2; emem := emem2; evm := vm2' |} vres1; eauto=> //=. + rewrite -eq_p_extra. rewrite /with_vm /=. case: (s0) Hi=> //=. - + have /= -> := write_vars_lvals gd fp vargs1' (with_vm s0 (evm s0)). apply Hw'. + + have /= -> := write_vars_lvals (~~direct_call) gd fp vargs1' (with_vm s0 (evm s0)). apply Hw'. + rewrite /with_vm /=. rewrite /with_vm /= in Hsem'. - have /= <- := sem_pexprs_get_var gd {| escs := escs2; emem := emem2; evm := vm2' |} (fn_keep_only onfun fn res). + have /= <- := sem_pexprs_get_var (~~direct_call) gd {| escs := escs2; emem := emem2; evm := vm2' |} (fn_keep_only onfun fn res). apply Hres''. Qed. @@ -634,7 +598,7 @@ Lemma dead_code_tokeep_callPu (p p': uprog) do_nop onfun fn ev scs mem scs' mem' sem_call p ev scs mem fn va scs' mem' vr -> exists vr', sem_call p' ev scs mem fn va scs' mem' vr' /\ List.Forall2 value_uincl (fn_keep_only onfun fn vr) vr'. -Proof. by move=> hd hall;apply: (dead_code_callP wf_initu hd); apply List_Forall2_refl. Qed. +Proof. by move=> hd hall;apply: (dead_code_callP hd); apply List_Forall2_refl. Qed. Lemma dead_code_tokeep_callPs (p p': sprog) do_nop onfun fn wrip scs mem scs' mem' va va' vr: dead_code_prog_tokeep is_move_op do_nop onfun p = ok p' -> @@ -642,7 +606,7 @@ Lemma dead_code_tokeep_callPs (p p': sprog) do_nop onfun fn wrip scs mem scs' me sem_call p wrip scs mem fn va scs' mem' vr -> exists vr', sem_call p' wrip scs mem fn va scs' mem' vr' /\ List.Forall2 value_uincl (fn_keep_only onfun fn vr) vr'. -Proof. by move=> hd hall;apply: (dead_code_callP wf_inits hd); apply List_Forall2_refl. Qed. +Proof. by move=> hd hall;apply: (dead_code_callP hd); apply List_Forall2_refl. Qed. Lemma dead_code_callPu (p p': uprog) do_nop fn ev scs mem scs' mem' va va' vr: dead_code_prog is_move_op p do_nop = ok p' -> diff --git a/proofs/compiler/direct_call_proof.v b/proofs/compiler/direct_call_proof.v new file mode 100644 index 000000000..c1a1fadb3 --- /dev/null +++ b/proofs/compiler/direct_call_proof.v @@ -0,0 +1,283 @@ +(* ** Imports and settings *) +From mathcomp Require Import all_ssreflect all_algebra. +Require Import varmap psem. + +Import Utf8. + + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +(* ** proofs + * -------------------------------------------------------------------- *) + +Section WITH_PARAMS. + +Context + {wsw:WithSubWord} + {asm_op syscall_state : Type} + {ep : EstateParams syscall_state} + {spp : SemPexprParams} + {sip : SemInstrParams asm_op syscall_state} + {T : eqType} + {pT : progT T} + {sCP : semCallParams}. + +Context (p:prog) (ev:extra_val_t). + +#[local] Open Scope vm_scope. + +Let Pi_r s1 (i:instr_r) s2:= + forall (vm1:Vm.t), evm s1 <=1 vm1 -> + exists2 vm2, evm s2 <=1 vm2 & sem_i (dc:= direct_c) p ev (with_vm s1 vm1) i (with_vm s2 vm2). + +Let Pi s1 (i:instr) s2:= + forall (vm1:Vm.t), evm s1 <=1 vm1 -> + exists2 vm2, evm s2 <=1 vm2 & sem_I (dc:= direct_c) p ev (with_vm s1 vm1) i (with_vm s2 vm2). + +Let Pc s1 (c:cmd) s2:= + forall (vm1:Vm.t), evm s1 <=1 vm1 -> + exists2 vm2, evm s2 <=1 vm2 & sem (dc:= direct_c) p ev (with_vm s1 vm1) c (with_vm s2 vm2). + +Let Pfor (i:var_i) vs s1 c s2 := + forall (vm1:Vm.t), evm s1 <=1 vm1 -> + exists2 vm2, evm s2 <=1 vm2 & sem_for (dc:= direct_c) p ev i vs (with_vm s1 vm1) c (with_vm s2 vm2). + +Let Pfun scs m fn vargs scs' m' vres := + forall vargs', List.Forall2 value_uincl vargs vargs' -> + exists2 vres', + sem_call (dc:= direct_c) p ev scs m fn vargs' scs' m' vres' & + List.Forall2 value_uincl vres vres'. + +Local Lemma Hskip : sem_Ind_nil Pc. +Proof. move=> s1 vm1 hle; eexists; eauto; constructor. Qed. + +Local Lemma Hcons : sem_Ind_cons (dc:=indirect_c) p ev Pc Pi. +Proof. + move=> s1 s2 s3 i c _ hi _ hc vm1 /hi [] vm2 /hc [vm3] hle hc' hi'. + exists vm3 => //; econstructor; eauto. +Qed. + +Local Lemma HmkI : sem_Ind_mkI (dc:=indirect_c) p ev Pi_r Pi. +Proof. move=> ii i s1 s2 _ hi vm1 /hi [vm2 hle hi']; exists vm2 => //; constructor. Qed. + +Local Lemma Hassgn : sem_Ind_assgn p Pi_r. +Proof. + move=> s1 s2 x t ty e v v' he htr hw vm1 hle. + have [v1 he1 hu1]:= sem_pexpr_uincl hle he. + have [v1' htr1 hu1' ] := value_uincl_truncate hu1 htr. + have [vm2 hw2 hle2]:= write_uincl hle hu1' hw. + exists vm2 => //; econstructor; eauto. +Qed. + +Local Lemma Hopn : sem_Ind_opn p Pi_r. +Proof. + move => s1 s2 t o xs es; rewrite /sem_sopn; t_xrbindP => vrs ves hes hex hws vm1 hle. + have [ves1 hes1 hu1]:= sem_pexprs_uincl hle hes. + have [vrs1 hex1 hu1'] := vuincl_exec_opn hu1 hex. + have [vm2 hws2 hle2]:= writes_uincl hle hu1' hws. + exists vm2 => //; econstructor; eauto. + by rewrite /sem_sopn hes1 /= hex1 /= hws2. +Qed. + +Local Lemma Hsyscall : sem_Ind_syscall p Pi_r. +Proof. + move=> s1 scs m s2 o xs es ves vs hes hex hws vm1 hle. + have [ves1 hes1 hu1]:= sem_pexprs_uincl hle hes. + have [vrs1 hex1 hu1'] := exec_syscallP hex hu1. + have [vm2 Hw ?]:= writes_uincl (s1 := with_scs (with_mem s1 m) scs) hle hu1' hws. + exists vm2 => //; econstructor; eauto. +Qed. + +Local Lemma Hif_true : sem_Ind_if_true (dc:=indirect_c) p ev Pc Pi_r. +Proof. + move=> s1 s2 e c1 c2 he _ hc vm1 hle. + have [v' he1 /value_uinclE ?]:= sem_pexpr_uincl hle he; subst v'. + by have [vm2 ??]:= hc _ hle;exists vm2 => //; apply Eif_true. +Qed. + +Local Lemma Hif_false : sem_Ind_if_false (dc:=indirect_c) p ev Pc Pi_r. +Proof. + move=> s1 s2 e c1 c2 he _ hc vm1 hle. + have [v' he1 /value_uinclE ?]:= sem_pexpr_uincl hle he; subst v'. + by have [vm2 ??]:= hc _ hle;exists vm2 => //; apply Eif_false. +Qed. + +Local Lemma Hwhile_true : sem_Ind_while_true (dc:=indirect_c) p ev Pc Pi_r. +Proof. + move=> s1 s2 s3 s4 a c e c' _ hc he _ hc' _ hw vm1 hle. + have [vm2 hle2 hs2] := hc _ hle. + have [v' he2 /value_uinclE ?]:= sem_pexpr_uincl hle2 he;subst. + have [vm3 /hw [vm4 hle4 hs4] hs3]:= hc' _ hle2;exists vm4 => //; eapply Ewhile_true; eauto. +Qed. + +Local Lemma Hwhile_false : sem_Ind_while_false (dc:=indirect_c) p ev Pc Pi_r. +Proof. + move=> s1 s2 a c e c' _ hc he vm1 hle. + have [vm2 hle2 hs2] := hc _ hle. + have [v' he' /value_uinclE ?]:= sem_pexpr_uincl hle2 he;subst. + by exists vm2 => //;apply: Ewhile_false. +Qed. + +Local Lemma Hfor : sem_Ind_for (dc:=indirect_c) p ev Pi_r Pfor. +Proof. + move=> s1 s2 i d lo hi c vlo vhi hlo hhi _ hfor vm1 hle. + have [? ? /value_uinclE ?]:= sem_pexpr_uincl hle hlo;subst. + have [? ? /value_uinclE ?]:= sem_pexpr_uincl hle hhi;subst. + by have [vm2 ??]:= hfor _ hle; exists vm2 => //; econstructor; eauto. +Qed. + +Local Lemma Hfor_nil : sem_Ind_for_nil Pfor. +Proof. by move=> s i c vm1 ?;exists vm1 => //;constructor. Qed. + +Local Lemma Hfor_cons : sem_Ind_for_cons (dc:=indirect_c) p ev Pc Pfor. +Proof. + move=> s1 s1' s2 s3 i w ws c hw _ hc _ hf vm1 hle. + have [vm1' Hi' /hc] := write_var_uincl hle (value_uincl_refl _) hw. + move=> [vm2 /hf [vm3 hle3 ?] ?]; exists vm3 => //; econstructor; eauto. +Qed. + +Section EXPR. + + Context (wdb : bool) (gd : glob_decls) (s : estate). + + Let P e : Prop := forall v, sem_pexpr true gd s e = ok v -> sem_pexpr wdb gd s e = ok v. + + Let Q es : Prop := forall vs, sem_pexprs true gd s es = ok vs -> sem_pexprs wdb gd s es = ok vs. + + Lemma get_var_weak vm x v : get_var true vm x = ok v → get_var wdb vm x = ok v. + Proof. by move => /get_varP []; rewrite /get_var /= => -> -> _; rewrite orbT. Qed. + + Lemma get_gvar_weak vm (x : gvar) v : get_gvar true gd vm x = ok v → get_gvar wdb gd vm x = ok v. + Proof. rewrite /get_gvar; case: ifP => // _; apply get_var_weak. Qed. + + Lemma sem_pexpr_weak_and : (∀ e, P e) ∧ (∀ es, Q es). + Proof. + apply: pexprs_ind_pair; subst P Q; split => //=; t_xrbindP. + + by move=> e he es hes vs v /he -> /= ? /hes -> <-. + + by apply get_gvar_weak. + + move=> > he >; apply on_arr_gvarP => ?? hty /get_gvar_weak -> /=. + by t_xrbindP => > /he -> /= -> /= > -> <-. + + move=> > he >; apply on_arr_gvarP => ?? hty /get_gvar_weak -> /=. + by t_xrbindP => > /he -> /= -> /= > -> <-. + + by move=> > he > /get_var_weak -> /= -> > /he -> /= -> > /= -> <-. + + by move=> > he > /he -> /= ->. + + by move=> > he1 > he2 > /he1 -> /= > /he2 -> /= ->. + + by move=> > hes > /hes; rewrite /sem_pexprs => -> /= ->. + by move=> > he > he1 > he2 > /he -> /= > -> /= > /he1 -> /= -> /= > /he2 -> /= -> <-. + Qed. + + Lemma sem_pexpr_weak e v : sem_pexpr true gd s e = ok v -> sem_pexpr wdb gd s e = ok v. + Proof. case: sem_pexpr_weak_and => h _; apply:h. Qed. + + Lemma sem_pexprs_weak es vs : sem_pexprs true gd s es = ok vs -> sem_pexprs wdb gd s es = ok vs. + Proof. case: sem_pexpr_weak_and => _ h; apply:h. Qed. + + Lemma truncatable_weak t v : truncatable true t v -> truncatable wdb t v. + Proof. + move=> /vm_truncate_valE; case: v. + 1-3: by move=> > [] ->. + + by move=> > [] > [-> /= ->]; rewrite orbT. + by move=> > []. + Qed. + + Lemma DB_weak v : DB true v -> DB wdb v. + Proof. by rewrite /DB /= => ->; rewrite orbT. Qed. + + Lemma set_var_weak vm x v vm' : set_var true vm x v = ok vm' -> set_var wdb vm x v = ok vm'. + Proof. by rewrite /set_var; t_xrbindP => /DB_weak -> /truncatable_weak -> <-. Qed. + + Lemma write_var_weak x v s' : write_var true x v s = ok s' → write_var wdb x v s = ok s'. + Proof. by rewrite /write_var; t_xrbindP => > /set_var_weak -> <-. Qed. + + Lemma write_lval_weak s' x v : write_lval true gd x v s = ok s' -> write_lval wdb gd x v s = ok s'. + Proof. + case: x => [vi t | x | ws x e | aa ws x e | aa ws len x e] /=; t_xrbindP. + + by rewrite /write_none; t_xrbindP => /truncatable_weak -> /DB_weak -> ->. + + by apply write_var_weak. + + by move=> ? > /get_var_weak -> /= -> > /sem_pexpr_weak -> /= -> > -> > /= -> <-. + + apply on_arr_varP => > ? /get_var_weak -> /=. + by t_xrbindP => > /sem_pexpr_weak -> /= -> > -> > /= -> /write_var_weak /= ->. + apply on_arr_varP => > ? /get_var_weak -> /=. + by t_xrbindP => > /sem_pexpr_weak -> /= -> > -> > /= -> /write_var_weak /= ->. + Qed. + +End EXPR. + +Lemma write_vars_weak wdb s xs vs s' : write_vars true xs vs s = ok s' → write_vars wdb xs vs s = ok s'. +Proof. + elim: xs vs s => [ | x xs hrec] [ | v vs] //= s. + by t_xrbindP => > /(write_var_weak wdb) -> /= /hrec. +Qed. + +Lemma write_lvals_weak wdb gd s s' xs vs : + write_lvals true gd s xs vs = ok s' → write_lvals wdb gd s xs vs = ok s'. +Proof. + elim: xs vs s => [ | x xs hrec] [ | v vs] //= s. + by t_xrbindP => > /(write_lval_weak wdb) -> /= /hrec. +Qed. + +Local Lemma Hcall : sem_Ind_call (dc:=indirect_c) p ev Pi_r Pfun. +Proof. + move=> s1 scs2 m2 s2 ii xs fn args vargs vs hargs _ hrec hws vm1 hle. + have [vargs' /(sem_pexprs_weak false) hargs1 /hrec[vres' hc hu]]:= sem_pexprs_uincl hle hargs. + have [vm2 /(write_lvals_weak false)hws2 hle2]:= writes_uincl (s1 := with_scs (with_mem s1 m2) scs2) hle hu hws. + exists vm2 => //; econstructor; eauto. +Qed. + +Lemma mapM2_dc_truncate_weak ty vs1 vs2 vs' : + List.Forall2 value_uincl vs1 vs2 -> + mapM2 ErrType (dc_truncate_val (dc:=indirect_c)) ty vs1 = ok vs' -> + mapM2 ErrType (dc_truncate_val (dc:=direct_c)) ty vs2 = ok vs2. +Proof. + by elim: ty vs1 vs2 vs' => [| t ty hrec] > [] // > _ hu /=; t_xrbindP => > _ > /(hrec _ _ _ hu) ->. +Qed. + +Local Lemma Hproc : sem_Ind_proc (dc:=indirect_c) p ev Pc Pfun. +Proof. + move=> scs1 m1 scs2 m2 fn f vargs vargs' s0 s1 s2 vres vres' hget htra hinit hw _ hc hgetr htrr -> -> vargs1 hu. + have htra1 := mapM2_dc_truncate_weak hu htra. + have {hu} hu:= Forall2_trans value_uincl_trans (mapM2_dc_truncate_value_uincl htra) hu. + assert (h := write_vars_uincl (vm_uincl_refl (evm s0)) hu hw). + case: h=> vm1; rewrite with_vm_same => /(write_vars_weak false) hw1 /hc [vm2 hle2 hc2]. + have [vres2 hgetr2 hu2]:= get_vars_uincl hle2 hgetr. + have htrr2 := mapM2_dc_truncate_weak hu2 htrr. + exists vres2; last first. + + by apply: (Forall2_trans value_uincl_trans) hu2; apply: mapM2_dc_truncate_value_uincl htrr. + econstructor; eauto => /=. + elim: (f_res f) (vres2) hgetr2 => [ | t ty hrec] /=; t_xrbindP. + + by move=> _ <-. + by move=> > /get_varP [-> _ _] > /hrec -> <-. +Qed. + +Lemma indirect_2_direct scs m fn va scs' m' vr : + sem_call (dc := indirect_c) p ev scs m fn va scs' m' vr → + exists2 vr', + List.Forall2 value_uincl vr vr' & + sem_call (dc := direct_c) p ev scs m fn va scs' m' vr'. +Proof. + move=> Hsem. + have [ ] := + (sem_call_Ind + Hskip + Hcons + HmkI + Hassgn + Hopn + Hsyscall + Hif_true + Hif_false + Hwhile_true + Hwhile_false + Hfor + Hfor_nil + Hfor_cons + Hcall + Hproc + Hsem + va + (List_Forall2_refl va value_uincl_refl)). eauto. +Qed. + +End WITH_PARAMS. diff --git a/proofs/compiler/inline.v b/proofs/compiler/inline.v index a6ee0dd41..6000e39d8 100644 --- a/proofs/compiler/inline.v +++ b/proofs/compiler/inline.v @@ -7,7 +7,6 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope vmap. Local Open Scope seq_scope. Module Import E. @@ -32,6 +31,7 @@ End E. Section INLINE. Context + {wsw : WithSubWord} {asm_op syscall_state : Type} {asmop:asmOp asm_op}. diff --git a/proofs/compiler/inline_proof.v b/proofs/compiler/inline_proof.v index e03356fc6..26b4f7cdc 100644 --- a/proofs/compiler/inline_proof.v +++ b/proofs/compiler/inline_proof.v @@ -8,12 +8,12 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope vmap. Local Open Scope seq_scope. Section INLINE. Context + {wsw : WithSubWord} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} @@ -28,6 +28,8 @@ Local Notation inline_i' := (inline_i rename_fd). Local Notation inline_fd' := (inline_fd rename_fd). Local Notation inline_prog' := (inline_prog rename_fd). +#[local] Existing Instance indirect_c. + Section INCL. Variable p p': ufun_decls. @@ -201,9 +203,9 @@ End SUBSET. Lemma assgn_tuple_Lvar (p:uprog) (ev:unit) ii (xs:seq var_i) flag tys es vs vs' s s' : let xs := map Lvar xs in disjoint (vrvs xs) (read_es es) -> - sem_pexprs (p_globs p) s es = ok vs -> - mapM2 ErrType truncate_val tys vs = ok vs' -> - write_lvals (p_globs p) s xs vs' = ok s' -> + sem_pexprs true (p_globs p) s es = ok vs -> + mapM2 ErrType dc_truncate_val tys vs = ok vs' -> + write_lvals true (p_globs p) s xs vs' = ok s' -> sem p ev s (assgn_tuple ii xs flag tys es) s'. Proof. rewrite /disjoint /assgn_tuple /is_true Sv.is_empty_spec. @@ -218,27 +220,21 @@ Proof. apply Eseq with s1. + by constructor;econstructor;eauto. apply: Hrec htrs Hws;first by SvD.fsetdec. - apply:rbindP Hw => vm;apply: on_vuP. - + move=> z ? <- [<-] /=. - rewrite -Hves=> {Hse Hves};case:s => scs sm svm /=. - apply: read_es_eq_on_empty. - by rewrite read_esE => y Hy;rewrite Fv.setP_neq //;apply/eqP;SvD.fsetdec. - case:ifP => //= _ ? [<-] [<-] /=. - rewrite -Hves=> {Hse Hves};case:s => scs sm svm /=. - apply: read_es_eq_on_empty. - by rewrite read_esE => y Hy;rewrite Fv.setP_neq //;apply/eqP;SvD.fsetdec. + symmetry; rewrite -Hves; apply eq_on_sem_pexprs. + + by apply: write_var_memP Hw. + apply: (eq_ex_disjoint_eq_on (vrvP_var Hw)); apply /disjointP; SvD.fsetdec. Qed. Lemma assgn_tuple_Pvar (p:uprog) ev ii xs flag tys rxs vs vs' s s' : let es := map Plvar rxs in disjoint (vrvs xs) (read_es es) -> - mapM (fun x : var_i => get_var (evm s) x) rxs = ok vs -> - mapM2 ErrType truncate_val tys vs = ok vs' -> - write_lvals (p_globs p) s xs vs' = ok s' -> + mapM (fun x : var_i => get_var true (evm s) x) rxs = ok vs -> + mapM2 ErrType dc_truncate_val tys vs = ok vs' -> + write_lvals true (p_globs p) s xs vs' = ok s' -> sem p ev s (assgn_tuple ii xs flag tys es) s'. Proof. rewrite /disjoint /assgn_tuple /is_true Sv.is_empty_spec. - have : evm s = evm s [\vrvs xs] by done. + have : evm s =[\vrvs xs] evm s by done. have : Sv.Subset (vrvs xs) (vrvs xs) by done. move: {1 3}s => s0;move: {2 3 4}(vrvs xs) => X. elim: xs rxs tys vs vs' s s' => [ | x xs Hrec] [ | rx rxs] [ | ty tys] [ | v vs] vs' s s' //=. @@ -272,29 +268,28 @@ Section PROOF. Let Pi_r s1 (i:instr_r) s2:= forall ii X1 X2 c', inline_i' (p_funcs p') (MkI ii i) X2 = ok (X1, c') -> - forall vm1, wf_vm vm1 -> evm s1 <=[X1] vm1 -> - exists vm2, [/\ wf_vm vm2, evm s2 <=[X2] vm2 & - sem p' ev (with_vm s1 vm1) c' (with_vm s2 vm2)]. + forall vm1, evm s1 <=[X1] vm1 -> + exists2 vm2, evm s2 <=[X2] vm2 & sem p' ev (with_vm s1 vm1) c' (with_vm s2 vm2). Let Pi s1 (i:instr) s2:= forall X1 X2 c', inline_i' (p_funcs p') i X2 = ok (X1, c') -> - forall vm1, wf_vm vm1 -> evm s1 <=[X1] vm1 -> - exists vm2, [/\ wf_vm vm2, evm s2 <=[X2] vm2 & - sem p' ev (with_vm s1 vm1) c' (with_vm s2 vm2)]. + forall vm1, evm s1 <=[X1] vm1 -> + exists2 vm2, evm s2 <=[X2] vm2 & + sem p' ev (with_vm s1 vm1) c' (with_vm s2 vm2). Let Pc s1 (c:cmd) s2:= forall X1 X2 c', inline_c (inline_i' (p_funcs p')) c X2 = ok (X1, c') -> - forall vm1, wf_vm vm1 -> evm s1 <=[X1] vm1 -> - exists vm2, [/\ wf_vm vm2, evm s2 <=[X2] vm2 & - sem p' ev (with_vm s1 vm1) c' (with_vm s2 vm2)]. + forall vm1, evm s1 <=[X1] vm1 -> + exists2 vm2, evm s2 <=[X2] vm2 & + sem p' ev (with_vm s1 vm1) c' (with_vm s2 vm2). Let Pfor (i:var_i) vs s1 c s2 := forall X1 X2 c', inline_c (inline_i' (p_funcs p')) c X2 = ok (X1, c') -> Sv.Equal X1 X2 -> - forall vm1, wf_vm vm1 -> evm s1 <=[X1] vm1 -> - exists vm2, [/\ wf_vm vm2, evm s2 <=[X2] vm2 & - sem_for p' ev i vs (with_vm s1 vm1) c' (with_vm s2 vm2)]. + forall vm1, evm s1 <=[X1] vm1 -> + exists2 vm2, evm s2 <=[X2] vm2 & + sem_for p' ev i vs (with_vm s1 vm1) c' (with_vm s2 vm2). Let Pfun scs m fn vargs scs' m' vres := forall vargs', List.Forall2 value_uincl vargs vargs' -> @@ -303,14 +298,14 @@ Section PROOF. List.Forall2 value_uincl vres vres'. Local Lemma Hskip : sem_Ind_nil Pc. - Proof. move=> s X1 X2 c' [<- <-] vm1 Hwf Hvm1;exists vm1;split=>//;constructor. Qed. + Proof. move=> s X1 X2 c' [<- <-] vm1 Hvm1; exists vm1 => //; constructor. Qed. Local Lemma Hcons : sem_Ind_cons p ev Pc Pi. Proof. move=> s1 s2 s3 i c _ Hi _ Hc X1 X2 c0 /=;apply: rbindP => -[Xc c'] /Hc Hic. - apply:rbindP => -[Xi i'] /Hi Hii [<- <-] vm1 /Hii H/H{H} [vm2 []]. - move=> /Hic H/H{H} [vm3 [Hwf3 Hvm3 Hsc']] ?. - by exists vm3;split=> //;apply: sem_app Hsc'. + apply:rbindP => -[Xi i'] /Hi Hii [<- <-] vm1 /Hii [vm2 ]. + move=> /Hic [vm3 Hvm3 Hsc'] ?. + by exists vm3 => //; apply: sem_app Hsc'. Qed. Local Lemma HmkI : sem_Ind_mkI p ev Pi_r Pi. @@ -322,14 +317,12 @@ Section PROOF. Proof. move => s1 s2 x tag ty e ve ve'. case: s1 s2 => scs1 sm1 svm1 [scs2 sm2 svm2] Hse hsub hw ii X1 X2 c' [] <- <- vm1. - rewrite read_i_assgn => Hwf Hvm. - have h : svm1 <=[read_e e] vm1 by apply: vmap_uincl_onI Hvm;SvD.fsetdec. + rewrite read_i_assgn => Hvm. + have h : svm1 <=[read_e e] vm1 by apply: uincl_onI Hvm;SvD.fsetdec. have [v2 Hv2 Huv2 {h}] := sem_pexpr_uincl_on' h Hse. have [v2' hsub' huv2']:= value_uincl_truncate Huv2 hsub. have [ | vm2 /=Hvm2 Hw']:= write_lval_uincl_on _ huv2' hw Hvm; first by SvD.fsetdec. - exists vm2;split. - + by apply: wf_write_lval Hw'. - + by apply: vmap_uincl_onI Hvm2;SvD.fsetdec. + exists vm2; first by apply: uincl_onI Hvm2;SvD.fsetdec. by apply: sem_seq1;constructor;econstructor; rewrite -?eq_globs;eauto. Qed. @@ -338,14 +331,12 @@ Section PROOF. move => s1 s2 t o xs es. case: s1 s2 => scs1 sm1 svm1 [ scs2 sm2 svm2]. apply: rbindP => ve;t_xrbindP => vs Hse Hso Hw ii X1 X2 c' [] <- <- vm1. - rewrite read_i_opn => Hwf Hvm. - have h : svm1 <=[read_es es] vm1 by apply: vmap_uincl_onI Hvm;SvD.fsetdec. + rewrite read_i_opn => Hvm. + have h : svm1 <=[read_es es] vm1 by apply: uincl_onI Hvm;SvD.fsetdec. have [v2 Hv2 Huv2 {h}] := sem_pexprs_uincl_on' h Hse. have [v2' Hso' Huv2' ]:= vuincl_exec_opn Huv2 Hso. have [ | vm2 /=Hvm2 Hw']:= write_lvals_uincl_on _ Huv2' Hw Hvm; first by SvD.fsetdec. - exists vm2;split. - + by apply: wf_write_lvals Hw'. - + by apply: vmap_uincl_onI Hvm2;SvD.fsetdec. + exists vm2; first by apply: uincl_onI Hvm2;SvD.fsetdec. by apply: sem_seq1;constructor;constructor;rewrite -eq_globs /sem_sopn Hv2 /= Hso'. Qed. @@ -353,14 +344,12 @@ Section PROOF. Proof. move => s1 scs m s2 o xs es ves vs. case: s1 s2 => scs1 sm1 svm1 [ scs2 sm2 svm2] Hse Hso Hw ii X1 X2 c' [] <- <- vm1. - rewrite read_i_syscall => Hwf Hvm. - have h : svm1 <=[read_es es] vm1 by apply: vmap_uincl_onI Hvm;SvD.fsetdec. + rewrite read_i_syscall => Hvm. + have h : svm1 <=[read_es es] vm1 by apply: uincl_onI Hvm;SvD.fsetdec. have [v2 Hv2 Huv2 {h}] := sem_pexprs_uincl_on' h Hse. have [v2' Hso' Huv2']:= exec_syscallP Hso Huv2. have [ | vm2 /=Hvm2 Hw']:= write_lvals_uincl_on _ Huv2' Hw Hvm; first by SvD.fsetdec. - exists vm2;split. - + by apply: wf_write_lvals Hw'. - + by apply: vmap_uincl_onI Hvm2;SvD.fsetdec. + exists vm2; first by apply: uincl_onI Hvm2;SvD.fsetdec. by apply: sem_seq1; constructor; econstructor; eauto; rewrite -eq_globs. Qed. @@ -369,11 +358,11 @@ Section PROOF. move => s1 s2 e c1 c2. case: s1 => scs1 sm1 svm1 Hse _ Hc ii X1 X2 c'. apply: rbindP => -[Xc1 c1'] /Hc Hc1;apply: rbindP => -[Xc2 c2'] ? [<- <-] vm1. - rewrite read_eE=> Hwf Hvm1. - case: (Hc1 vm1 _)=>//;first by apply: vmap_uincl_onI Hvm1;SvD.fsetdec. - move=> vm2 [Hvm2 Hc1'];exists vm2;split=>//. + rewrite read_eE=> Hvm1. + case: (Hc1 vm1 _)=>//;first by apply: uincl_onI Hvm1;SvD.fsetdec. + move=> vm2 Hvm2 Hc1';exists vm2 => //. apply sem_seq1;constructor;apply Eif_true => //. - have h : svm1 <=[read_e e] vm1 by apply: vmap_uincl_onI Hvm1;SvD.fsetdec. + have h : svm1 <=[read_e e] vm1 by apply: uincl_onI Hvm1;SvD.fsetdec. have {h} := sem_pexpr_uincl_on' h Hse. by rewrite -eq_globs => -[ve' -> /value_uinclE -> /=]. Qed. @@ -383,11 +372,11 @@ Section PROOF. move => s1 s2 e c1 c2. case: s1 => scs1 sm1 svm1 Hse _ Hc ii X1 X2 c'. apply: rbindP => -[Xc1 c1'] ?;apply: rbindP => -[Xc2 c2'] /Hc Hc2 [<- <-] vm1. - rewrite read_eE=> Hwf Hvm1. - case: (Hc2 vm1 _)=>//;first by apply: vmap_uincl_onI Hvm1;SvD.fsetdec. - move=> vm2 [Hvm2 Hc1'];exists vm2;split=>//. + rewrite read_eE=> Hvm1. + case: (Hc2 vm1 _)=>//;first by apply: uincl_onI Hvm1;SvD.fsetdec. + move=> vm2 Hvm2 Hc1'; exists vm2 => //. apply sem_seq1;constructor;apply Eif_false => //. - have h : svm1 <=[read_e e] vm1 by apply: vmap_uincl_onI Hvm1;SvD.fsetdec. + have h : svm1 <=[read_e e] vm1 by apply: uincl_onI Hvm1;SvD.fsetdec. have {h} := sem_pexpr_uincl_on' h Hse. by rewrite -eq_globs => -[ve' -> /value_uinclE ->]. Qed. @@ -397,18 +386,18 @@ Section PROOF. move => s1 s2 s3 s4 a c e c'. case: s1 => scs1 sm1 svm1 Hsc Hc Hse Hsc' Hc' _ Hw ii X1 X2 cw Hi. move: (Hi) => /=;set X3 := Sv.union _ _;apply: rbindP => -[Xc c1] Hc1. - apply: rbindP => -[Xc' c1'] Hc1' [] ??;subst X1 cw => vm1 Hwf Hvm1. - case : (Hc _ _ _ Hc1 _ Hwf) => [| vm2 [Hwf2 Hvm2 Hsc1]]. - + apply: vmap_uincl_onI Hvm1; have /= -> := inline_c_subset Hc1. + apply: rbindP => -[Xc' c1'] Hc1' [] ??;subst X1 cw => vm1 Hvm1. + case : (Hc _ _ _ Hc1 vm1) => [| vm2 Hvm2 Hsc1]. + + apply: uincl_onI Hvm1; have /= -> := inline_c_subset Hc1. by rewrite /X3 read_i_while;SvD.fsetdec. - case : (Hc' _ _ _ Hc1' _ Hwf2) => [| vm3 [Hwf3 Hvm3 Hsc2]]. - + apply: vmap_uincl_onI Hvm2; have /= -> := inline_c_subset Hc1'. + case : (Hc' _ _ _ Hc1' vm2) => [| vm3 Hvm3 Hsc2]. + + apply: uincl_onI Hvm2; have /= -> := inline_c_subset Hc1'. by rewrite /X3 read_i_while;SvD.fsetdec. - have [vm4 [Hwf4 Hvm4 Hsw]]:= Hw _ _ _ _ Hi _ Hwf3 Hvm3. - exists vm4;split => //;apply sem_seq1;constructor. + have [vm4 Hvm4 Hsw]:= Hw _ _ _ _ Hi _ Hvm3. + exists vm4 => //;apply sem_seq1;constructor. case/semE: Hsw => si [] /sem_IE Hsw /semE ?; subst si. apply: (Ewhile_true Hsc1) Hsc2 Hsw. - have h : (evm s2) <=[read_e e] vm2 by apply: vmap_uincl_onI Hvm2;rewrite /X3 read_i_while;SvD.fsetdec. + have h : (evm s2) <=[read_e e] vm2 by apply: uincl_onI Hvm2;rewrite /X3 read_i_while;SvD.fsetdec. case: (s2) h Hse => ??? h Hse. have {h} := sem_pexpr_uincl_on' h Hse. by rewrite -eq_globs => -[? -> /value_uinclE ->]. @@ -419,14 +408,14 @@ Section PROOF. move => s1 s2 a c e c'. case: s1 s2 => scs1 sm1 svm1 [scs2 sm2 svm2] Hsc Hc Hse ii X1 X2 cw /=. set X3 := Sv.union _ _;apply: rbindP => -[Xc c1] Hc1. - apply: rbindP => -[Xc' c1'] Hc1' [] ??;subst X1 cw => vm1 Hwf Hvm1. - case : (Hc _ _ _ Hc1 _ Hwf) => [| vm2 [/=Hwf2 Hvm2 Hsc1]]. - + apply: vmap_uincl_onI Hvm1; have /= -> := inline_c_subset Hc1. + apply: rbindP => -[Xc' c1'] Hc1' [] ??;subst X1 cw => vm1 Hvm1. + case : (Hc _ _ _ Hc1 vm1) => [| vm2 /= Hvm2 Hsc1]. + + apply: uincl_onI Hvm1; have /= -> := inline_c_subset Hc1. by rewrite /X3 read_i_while;SvD.fsetdec. - exists vm2;split=>//. - + by apply: vmap_uincl_onI Hvm2;rewrite /X3;SvD.fsetdec. + exists vm2 => //. + + by apply: uincl_onI Hvm2;rewrite /X3;SvD.fsetdec. apply sem_seq1;constructor;apply Ewhile_false => //. - have h : svm2 <=[read_e e] vm2 by apply: vmap_uincl_onI Hvm2;rewrite /X3 read_i_while;SvD.fsetdec. + have h : svm2 <=[read_e e] vm2 by apply: uincl_onI Hvm2;rewrite /X3 read_i_while;SvD.fsetdec. have {h} := sem_pexpr_uincl_on' h Hse. by rewrite -eq_globs => -[? -> /value_uinclE ->]. Qed. @@ -435,59 +424,57 @@ Section PROOF. Proof. move => s1 s2 i d lo hi c vlo vhi. case: s1 => scs1 sm1 svm1 Hlo Hhi _ Hf ii X1 X2 cf Hi. - apply: rbindP Hi => -[Xc' c'] Hi [??] vm1 Hwf Hvm1;subst. + apply: rbindP Hi => -[Xc' c'] Hi [??] vm1 Hvm1;subst. have Hxc': Sv.Equal Xc' (Sv.union (read_i (Cfor i (d, lo, hi) c)) X2). + by have /= -> := inline_c_subset Hi;rewrite read_i_for;SvD.fsetdec. - have [ /=| vm2 [Hwf2 Hvm2 Hsf]]:= Hf _ _ _ Hi Hxc' _ Hwf. - + by apply: vmap_uincl_onI Hvm1;rewrite Hxc'. - exists vm2;split=>//;first by apply: vmap_uincl_onI Hvm2;SvD.fsetdec. + have [ /=| vm2 Hvm2 Hsf]:= Hf _ _ _ Hi Hxc' vm1. + + by apply: uincl_onI Hvm1;rewrite Hxc'. + exists vm2 => //;first by apply: uincl_onI Hvm2;SvD.fsetdec. move: Hvm1;rewrite read_i_for => Hvm1. apply sem_seq1;constructor;eapply Efor;eauto=> /=. - + have h : svm1 <=[read_e lo] vm1 by apply: vmap_uincl_onI Hvm1; SvD.fsetdec. + + have h : svm1 <=[read_e lo] vm1 by apply: uincl_onI Hvm1; SvD.fsetdec. have := sem_pexpr_uincl_on' h Hlo. by rewrite -eq_globs => -[? -> /value_uinclE ->]. - have h: svm1 <=[read_e hi] vm1 by apply: vmap_uincl_onI Hvm1; SvD.fsetdec. + have h: svm1 <=[read_e hi] vm1 by apply: uincl_onI Hvm1; SvD.fsetdec. have := sem_pexpr_uincl_on' h Hhi. by rewrite -eq_globs => -[? -> /value_uinclE ->]. Qed. Local Lemma Hfor_nil : sem_Ind_for_nil Pfor. Proof. - move=> s i c X1 X2 c' Hc HX vm1 Hwf Hvm1;exists vm1;split=>//;first by rewrite -HX. + move=> s i c X1 X2 c' Hc HX vm1 Hvm1;exists vm1 => //;first by rewrite -HX. constructor. Qed. Local Lemma Hfor_cons : sem_Ind_for_cons p ev Pc Pfor. Proof. - move=> s1 s1' s2 s3 i w ws c Hwi _ Hc _ Hfor X1 X2 c' Hic HX vm1 Hwf Hvm1. - have [vm1' Hvm1' Hw]:= write_var_uincl_on' (value_uincl_refl _) Hwi Hvm1. - have /(_ Hwf)Hwf' := wf_write_var _ Hw. - have [|vm2 [] ]:= Hc _ _ _ Hic _ Hwf';first by apply: vmap_uincl_onI Hvm1';SvD.fsetdec. - rewrite -{1}HX => Hwf2 Hvm2 Hsc'. - have [vm3 [?? Hsf']] := Hfor _ _ _ Hic HX _ Hwf2 Hvm2. - by exists vm3;split=>//;apply: EForOne Hsc' Hsf'. + move=> s1 s1' s2 s3 i w ws c Hwi _ Hc _ Hfor X1 X2 c' Hic HX vm1 Hvm1. + have [vm1' Hw Hvm1']:= write_var_uincl_on (value_uincl_refl _) Hwi Hvm1. + have [|vm2 ]:= Hc _ _ _ Hic vm1';first by apply: uincl_onI Hvm1';SvD.fsetdec. + rewrite -{1}HX => Hvm2 Hsc'. + have [vm3 ? Hsf'] := Hfor _ _ _ Hic HX _ Hvm2. + by exists vm3 => //;apply: EForOne Hsc' Hsf'. Qed. Local Lemma Hcall : sem_Ind_call p ev Pi_r Pfun. Proof. move => s1 scs2 m2 s2 ii xs fn args vargs vs. case:s1 => scs1 sm1 svm1 /= Hes Hsc Hfun Hw ii' X1 X2 c' /=;case:ii;last first. - + move=> [<- <-] vm1 Hwf1 Hvm1. + + move=> [<- <-] vm1 Hvm1. have /(_ Sv.empty vm1) [|vargs' /= Hvargs' Huargs]:= sem_pexprs_uincl_on' _ Hes. - + by apply: vmap_uincl_onI Hvm1;rewrite read_i_call;SvD.fsetdec. + + by apply: uincl_onI Hvm1;rewrite read_i_call;SvD.fsetdec. have [vres' [Hscall Hvres]]:= Hfun _ Huargs. have [|vm2 /= Hvm2 Hxs] := write_lvals_uincl_on _ Hvres Hw Hvm1. + by rewrite read_i_call;SvD.fsetdec. - exists vm2;split. - + by apply: wf_write_lvals Hxs. - + by apply: vmap_uincl_onI Hvm2; rewrite read_i_call;SvD.fsetdec. + exists vm2. + + by apply: uincl_onI Hvm2; rewrite read_i_call;SvD.fsetdec. by apply sem_seq1;constructor;eapply Ecall;eauto;rewrite -eq_globs. t_xrbindP => fd' /get_funP Hfd'. have [fd [Hfd Hinline]] := inline_progP uniq_funname Hp Hfd'. rewrite /check_rename; t_xrbindP => Hcheckf /=. - case:ifP => // Hdisj _ ??;subst X1 c' => vm1 Hwf1 Hvm1. + case:ifP => // Hdisj _ ??;subst X1 c' => vm1 Hvm1. have /(_ Sv.empty vm1) [|vargs' /= Hvargs' Huargs]:= sem_pexprs_uincl_on' _ Hes. - + by apply: vmap_uincl_onI Hvm1;rewrite read_i_call;SvD.fsetdec. + + by apply: uincl_onI Hvm1;rewrite read_i_call;SvD.fsetdec. have [vres1 [Hscall Hvres]]:= Hfun _ Huargs. case: (sem_callE Hscall) => f []. rewrite Hfd' => /Some_inj <- {f}. @@ -499,16 +486,16 @@ Section PROOF. move=> {hvs' hs1 hsvm2 Hfd' Hfd Hcheckf Hsc Hinline}. move: Hdisj Hvm1;rewrite read_i_call. move: Htin Htout Hvs Hwv Hbody;set rfd := rename_fd _ _ => Htin Htout Hvs Hwv Hbody Hdisjoint Hvm1. - rewrite (write_vars_lvals gd) in Hwv. + rewrite (write_vars_lvals _ gd) in Hwv. have [||/= vm1' Wvm1' Uvm1'] := writes_uincl (vm1 := vm1) (v2 := vargs0) _ _ Hwv. - + by apply wf_vm_uincl. + by apply List_Forall2_refl. - have Uvmi : vm_uincl (evm (with_vm s1 vm1_)) vm1' by done. + + apply vm_uincl_init. + by apply List_Forall2_refl. + have Uvmi : evm (with_vm s1 vm1_) <=1 vm1' by done. have [/=vm3 [Hsem' Uvm3]]:= sem_uincl Uvmi Hbody. have [/=vs2' Hvs' Uvs']:= get_vars_uincl Uvm3 Hvs. have [vs' Htout' Uvs]:= mapM2_truncate_val Htout Uvs'. have Heqvm : svm1 <=[Sv.union (read_rvs xs) X2] vm3. - + apply: vmap_uincl_onT;first by apply: vmap_uincl_onI Hvm1;SvD.fsetdec. + + apply: uincl_onT;first by apply: uincl_onI Hvm1;SvD.fsetdec. apply: eq_on_uincl_on;apply eq_onT with vm1'. + apply: disjoint_eq_ons Wvm1'. move: Hdisjoint;rewrite /disjoint /is_true !Sv.is_empty_spec. @@ -519,10 +506,8 @@ Section PROOF. have HH: List.Forall2 value_uincl vs vs'. + by apply: (Forall2_trans value_uincl_trans Hvres); apply: (Forall2_trans value_uincl_trans Hall). have [|vm4 /= Hvm4 Hw']:= write_lvals_uincl_on _ HH Hw Heqvm;first by SvD.fsetdec. - exists vm4;split. - + apply: wf_write_lvals Hw';apply: (wf_sem Hsem') => -[xt xn]. - by have /(_ Hwf1 {|vtype := xt; vname := xn |}) /=:= wf_write_lvals _ Wvm1'. - + by apply: vmap_uincl_onI Hvm4;SvD.fsetdec. + exists vm4. + + by apply: uincl_onI Hvm4;SvD.fsetdec. apply sem_app with (with_vm s1 vm1'). + rewrite eq_globs !with_vm_idem in Hvargs', Wvm1'. apply: assgn_tuple_Lvar Hvargs' Htin Wvm1' => //. @@ -542,25 +527,24 @@ Section PROOF. case: fd Htin Hi Hw Hsem Hc Hres Htout Hfi => /= fi tin fx fc tout fxr fe Htin Hi Hw Hsem Hc Hres Htout Hfi. apply: rbindP => -[X fc'] /Hc{Hc} Hc [] ?;subst fd'. - move=> vargs1 Hall;move: Hw; rewrite (write_vars_lvals gd) => Hw. + move=> vargs1 Hall;move: Hw; rewrite (write_vars_lvals _ gd) => Hw. have heq : Sv.Equal (read_rvs [seq Lvar i | i <- fx]) Sv.empty. + elim: (fx);first by rewrite read_rvs_nil;SvD.fsetdec. by move=> ?? Hrec; rewrite /= read_rvs_cons /=;SvD.fsetdec. have [vargs1' htin' Hall'] := mapM2_truncate_val Htin Hall. - have /(_ X) [|/= vm1]:= write_lvals_uincl_on _ Hall' Hw (vmap_uincl_on_refl _). + have [|/=vm1] := write_lvals_uincl_on _ Hall' Hw (@uincl_on_refl _ _ X). + by rewrite heq; SvD.fsetdec. move=> hsub Hvm1; case: (Hc vm1) => /=. - + by apply: wf_write_lvals Hvm1; move: Hi => [<-];apply: wf_vmap0. - + by apply: vmap_uincl_onI hsub;SvD.fsetdec. - move=> vm2' [hwf hsvm2 hsem]. - move: Hres; have /= <- := (sem_pexprs_get_var gd svm2) => Hres. + + by apply: uincl_onI hsub;SvD.fsetdec. + move=> vm2' hsvm2 hsem. + move: Hres; have /= <- := (sem_pexprs_get_var _ gd svm2) => Hres. case: svm2 Hsem Hscs Hfi Hc hsvm2 hsem Hres => escs2 emem2 evm2 Hsem Hscs Hfi Hc hsvm2 hsem Hres. have [vres1 hvres1 Hall1]:= sem_pexprs_uincl_on hsvm2 Hres. have [vres1' hvres1' Hall1'] := mapM2_truncate_val Htout Hall1. exists vres1';split=> //;econstructor;eauto => /=. - + by move: Hvm1; rewrite (write_vars_lvals gd) with_vm_same. + + by move: Hvm1; rewrite (write_vars_lvals _ gd) with_vm_same. by rewrite - -(sem_pexprs_get_var + -(sem_pexprs_get_var _ gd {| escs := escs2; emem := emem2; evm := vm2'; |}). Qed. diff --git a/proofs/compiler/jasmin_compiler.v b/proofs/compiler/jasmin_compiler.v index b8847a4e7..bd40a131c 100644 --- a/proofs/compiler/jasmin_compiler.v +++ b/proofs/compiler/jasmin_compiler.v @@ -1,6 +1,6 @@ (** This module is meant as the minimal dependency of extracted code. *) Require compiler. -Require sem. +Require psem_defs. Require arm_params. Require x86_params. Require sem_params_of_arch_extra. diff --git a/proofs/compiler/lea_proof.v b/proofs/compiler/lea_proof.v index 371af7eee..d4b3b57a4 100644 --- a/proofs/compiler/lea_proof.v +++ b/proofs/compiler/lea_proof.v @@ -11,11 +11,12 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope vmap_scope. Local Open Scope seq_scope. + Section PROOF. Context + {wsw : WithSubWord} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} @@ -26,18 +27,18 @@ Section PROOF. Definition sem_lea sz vm l : exec (word sz) := Let base := - oapp (fun (x:var_i) => get_var vm x >>= to_word sz) (ok 0%R) l.(lea_base) in + oapp (fun (x:var_i) => get_var true vm x >>= to_word sz) (ok 0%R) l.(lea_base) in Let offset := - oapp (fun (x:var_i) => get_var vm x >>= to_word sz) (ok 0%R) l.(lea_offset) in + oapp (fun (x:var_i) => get_var true vm x >>= to_word sz) (ok 0%R) l.(lea_offset) in ok (wrepr sz l.(lea_disp) + (base + (wrepr sz l.(lea_scale) * offset)))%R. Lemma lea_constP sz w vm : sem_lea sz vm (lea_const w) = ok (wrepr sz w). Proof. by rewrite /sem_lea /lea_const /=; f_equal; ssring. Qed. - Lemma lea_varP x sz vm : sem_lea sz vm (lea_var x) = get_var vm x >>= to_word sz. + Lemma lea_varP x sz vm : sem_lea sz vm (lea_var x) = get_var true vm x >>= to_word sz. Proof. rewrite /sem_lea /lea_var /=. - case: (Let _ := get_var _ _ in _) => //= w. + case: (Let _ := get_var _ _ _ in _) => //= w. by rewrite wrepr0 wrepr1; f_equal; ssring. Qed. @@ -157,7 +158,7 @@ Section PROOF. (sz <= Uptr)%CMP -> (sz ≤ sz')%CMP → mk_lea sz e = Some l -> - sem_pexpr gd s e = ok (Vword w) -> + sem_pexpr true gd s e = ok (Vword w) -> sem_lea sz (evm s) l = ok (zero_extend sz w). Proof. rewrite /mk_lea => h1 h2 /obindI[] f [] /fexpr_of_pexprP h hrec /h. diff --git a/proofs/compiler/linearization_proof.v b/proofs/compiler/linearization_proof.v index bf9acf210..757b43d27 100644 --- a/proofs/compiler/linearization_proof.v +++ b/proofs/compiler/linearization_proof.v @@ -21,6 +21,8 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. +#[local] Existing Instance withsubword. + Section WITH_PARAMS. Context @@ -358,8 +360,8 @@ Definition LSem_step p s1 s2 : lsem1 p s1 s2 -> lsem p s1 s2 := rt_step _ _ s1 s2. Lemma snot_spec gd s e b : - sem_pexpr gd s e = ok (Vbool b) → - sem_pexpr gd s (snot e) = sem_pexpr gd s (Papp1 Onot e). + sem_pexpr true gd s e = ok (Vbool b) → + sem_pexpr true gd s (snot e) = sem_pexpr true gd s (Papp1 Onot e). Proof. elim: e b => //. - by case => // e _ b; rewrite /= /sem_sop1 /=; t_xrbindP => z -> b' /to_boolI -> _ /=; @@ -370,7 +372,7 @@ elim: e b => //. apply: (f_equal (@Ok _ _)); rewrite /= ?negb_and ?negb_or. move => st p hp e1 he1 e2 he2 b /=. t_xrbindP => bp vp -> /= -> trv1 v1 h1 htr1 trv2 v2 h2 htr2 /= h. -have : exists (b1 b2:bool), st = sbool /\ sem_pexpr gd s e1 = ok (Vbool b1) /\ sem_pexpr gd s e2 = ok (Vbool b2). +have : exists (b1 b2:bool), st = sbool /\ sem_pexpr true gd s e1 = ok (Vbool b1) /\ sem_pexpr true gd s e2 = ok (Vbool b2). + rewrite h1 h2;case: bp h => ?;subst. + have [??]:= truncate_valI htr1;subst st v1. by move: htr2; rewrite /truncate_val; t_xrbindP => /= b2 /to_boolI -> ?;eauto. @@ -402,9 +404,9 @@ Record h_linearization_params := let vm := evm s in let args := lip_allocate_stack_frame liparams rsp sz in let i := MkLI ii (Lopn args.1.1 args.1.2 args.2) in - let ts' := pword_of_word (ts - wrepr Uptr sz) in - let s' := with_vm s (vm.[rsp <- ok ts'])%vmap in - (vm.[rsp])%vmap = ok (pword_of_word ts) + let ts' := Vword (ts - wrepr Uptr sz) in + let s' := with_vm s vm.[rsp <- ts'] in + vm.[rsp] = Vword ts -> eval_instr lp i (of_estate s fn pc) = ok (of_estate s' fn pc.+1); @@ -414,9 +416,9 @@ Record h_linearization_params := let vm := evm s in let args := lip_free_stack_frame liparams rsp sz in let i := MkLI ii (Lopn args.1.1 args.1.2 args.2) in - let ts' := pword_of_word (ts + wrepr Uptr sz) in - let s' := with_vm s (vm.[rsp <- ok ts'])%vmap in - (vm.[rsp])%vmap = ok (pword_of_word ts) + let ts' := Vword (ts + wrepr Uptr sz) in + let s' := with_vm s vm.[rsp <- ts'] in + vm.[rsp] = Vword ts -> eval_instr lp i (of_estate s fn pc) = ok (of_estate s' fn pc.+1); @@ -434,22 +436,19 @@ Record h_linearization_params := -> vtmp <> vrsp -> vname (v_var r) \notin (lip_not_saved_stack liparams) -> v_var r <> vrsp - -> get_var (evm s) vrsp = ok (Vword ts) - -> wf_vm (evm s) + -> get_var true (evm s) vrsp = ok (Vword ts) -> exists vm', let: ls := of_estate s fn (size P) in let: s' := with_vm s vm' in let: ls' := of_estate s' fn (size P + size lcmd) in [/\ lsem lp ls ls' - , wf_vm vm' - , vm' = (evm s) - [\ Sv.add (v_var r) (Sv.add vtmp (Sv.add vrsp vflags)) ] - , get_var vm' vrsp = ok (Vword ts') - , get_var vm' (v_var r) = ok (Vword ts) + , vm' =[\ Sv.add (v_var r) (Sv.add vtmp (Sv.add vrsp vflags)) ] (evm s) + , get_var true vm' vrsp = ok (Vword ts') + , get_var true vm' (v_var r) = ok (Vword ts) & forall x, Sv.In x vflags - -> ~ is_ok (vm'.[x]%vmap) - -> (evm s).[x]%vmap = vm'.[x]%vmap + -> ~ is_defined vm'.[x] + -> (evm s).[x] = vm'.[x] ]; spec_lip_set_up_sp_stack : @@ -463,21 +462,19 @@ Record h_linearization_params := is_linear_of lp fn (P ++ lcmd ++ Q) -> isSome (lip_set_up_sp_stack liparams vrspi sz al off) -> vtmp <> vrsp - -> get_var (evm s) vrsp = ok (Vword ts) - -> wf_vm (evm s) + -> get_var true (evm s) vrsp = ok (Vword ts) -> write (emem s) (ts' + wrepr Uptr off)%R ts = ok m' -> exists vm', let: ls := of_estate s fn (size P) in let: s' := {| escs := escs s; evm := vm'; emem := m'; |} in let: ls' := of_estate s' fn (size P + size lcmd) in [/\ lsem lp ls ls' - , wf_vm vm' - , vm' = (evm s) [\ Sv.add vtmp (Sv.add vrsp vflags) ] - , get_var vm' vrsp = ok (Vword ts') + , vm' =[\ Sv.add vtmp (Sv.add vrsp vflags) ] (evm s) + , get_var true vm' vrsp = ok (Vword ts') & forall x, Sv.In x vflags - -> ~ is_ok (vm'.[x]%vmap) - -> (evm s).[x]%vmap = vm'.[x]%vmap + -> ~ is_defined vm'.[x] + -> (evm s).[x] = vm'.[x] ]; hlip_lassign : @@ -512,8 +509,8 @@ Section HLIPARAMS. Lemma spec_lmove lp s1 s2 x ws (w : word ws) (y: var_i) ii fn pc : isSome (lmove liparams x ws y) - -> get_var (evm s1) y = ok (Vword w) - -> write_var x (Vword w) s1 = ok s2 + -> get_var true (evm s1) y = ok (Vword w) + -> write_var true x (Vword w) s1 = ok s2 -> let li := of_olinstr_r ii (lmove liparams x ws y) in eval_instr lp li (of_estate s1 fn pc) = ok (of_estate s2 fn pc.+1). Proof. @@ -1076,7 +1073,7 @@ Section PROOF. Qed. Local Coercion emem : estate >-> mem. - Local Coercion evm : estate >-> vmap. + Local Coercion evm : estate >-> Vm.t. (** Relation between source and target memories - There is a well-aligned valid block in the target @@ -1212,16 +1209,16 @@ Section PROOF. Qed. Section MATCH_MEM_SEM_PEXPR. - Context (scs: syscall_state_t) (m m': mem) (vm: vmap) (M: match_mem m m'). + Context (scs: syscall_state_t) (m m': mem) (vm: Vm.t) (M: match_mem m m'). Let P (e: pexpr) : Prop := ∀ v, - sem_pexpr [::] {| escs := scs; emem := m ; evm := vm |} e = ok v → - sem_pexpr [::] {| escs := scs; emem := m' ; evm := vm |} e = ok v. + sem_pexpr true [::] {| escs := scs; emem := m ; evm := vm |} e = ok v → + sem_pexpr true [::] {| escs := scs; emem := m' ; evm := vm |} e = ok v. Let Q (es: pexprs) : Prop := ∀ vs, - sem_pexprs [::] {| escs := scs; emem := m ; evm := vm |} es = ok vs → - sem_pexprs [::] {| escs := scs; emem := m' ; evm := vm |} es = ok vs. + sem_pexprs true [::] {| escs := scs; emem := m ; evm := vm |} es = ok vs → + sem_pexprs true [::] {| escs := scs; emem := m' ; evm := vm |} es = ok vs. Lemma match_mem_sem_pexpr_pair : (∀ e, P e) ∧ (∀ es, Q es). Proof. @@ -1236,29 +1233,27 @@ Section PROOF. - by move => sz x e ihe v /=; t_xrbindP => ?? -> /= -> /= ?? /ihe -> /= -> /= ? /(mm_read_ok M) -> /= ->. - by move => op e ihe v /=; t_xrbindP => ? /ihe ->. - by move => op e1 ih1 e2 ih2 v /=; t_xrbindP => ? /ih1 -> ? /ih2 ->. - - by move => op es ih vs /=; t_xrbindP => ? /ih; rewrite -/(sem_pexprs [::] _ es) => ->. + - by move => op es ih vs /=; t_xrbindP => ? /ih; rewrite -/(sem_pexprs _ [::] _ es) => ->. by move => ty e ihe e1 ih1 e2 ih2 v /=; t_xrbindP => ?? /ihe -> /= -> ?? /ih1 -> /= -> ?? /ih2 -> /= -> /= ->. Qed. - Lemma match_mem_sem_pexpr e : P e. - Proof. exact: (proj1 match_mem_sem_pexpr_pair). Qed. + Lemma match_mem_sem_pexpr e : P e. + Proof. exact: (proj1 match_mem_sem_pexpr_pair). Qed. - Lemma match_mem_sem_pexprs es : Q es. - Proof. exact: (proj2 match_mem_sem_pexpr_pair). Qed. + Lemma match_mem_sem_pexprs es : Q es. + Proof. exact: (proj2 match_mem_sem_pexpr_pair). Qed. End MATCH_MEM_SEM_PEXPR. Lemma match_mem_write_lval scs1 m1 vm1 m1' scs2 m2 vm2 x v : match_mem m1 m1' → - write_lval [::] x v {| escs := scs1; emem := m1 ; evm := vm1 |} = ok {| escs := scs2; emem := m2 ; evm := vm2 |} → + write_lval true [::] x v {| escs := scs1; emem := m1 ; evm := vm1 |} = ok {| escs := scs2; emem := m2 ; evm := vm2 |} → exists2 m2', - write_lval [::] x v {| escs := scs1; emem := m1' ; evm := vm1 |} = ok {| escs := scs2; emem := m2' ; evm := vm2 |} & + write_lval true [::] x v {| escs := scs1; emem := m1' ; evm := vm1 |} = ok {| escs := scs2; emem := m2' ; evm := vm2 |} & match_mem m2 m2'. Proof. move => M; case: x => /= [ _ ty | x | ws x e | aa ws x e | aa ws n x e ]. - - case/write_noneP => - [] -> -> -> h; exists m1'; last exact: M. - rewrite /write_none. - by case: h => [ [u ->] | [ -> -> ] ]. + - by case/write_noneP; rewrite /write_none => -[-> -> ->] -> ->; exists m1'. - rewrite /write_var /=; t_xrbindP =>_ -> -> <- -> /=. by exists m1'. - t_xrbindP => ?? -> /= -> /= ?? /(match_mem_sem_pexpr M) -> /= -> /= ? -> /= ? /(mm_write M)[] ? -> /= M' <- <- <-. @@ -1269,9 +1264,9 @@ Section PROOF. Lemma match_mem_write_lvals scs1 m1 vm1 m1' scs2 m2 vm2 xs vs : match_mem m1 m1' → - write_lvals [::] {| escs := scs1; emem := m1 ; evm := vm1 |} xs vs = ok {| escs := scs2; emem := m2 ; evm := vm2 |} → + write_lvals true [::] {| escs := scs1; emem := m1 ; evm := vm1 |} xs vs = ok {| escs := scs2; emem := m2 ; evm := vm2 |} → exists2 m2', - write_lvals [::] {| escs := scs1; emem := m1' ; evm := vm1 |} xs vs = ok {| escs := scs2; emem := m2' ; evm := vm2 |} & + write_lvals true [::] {| escs := scs1; emem := m1' ; evm := vm1 |} xs vs = ok {| escs := scs2; emem := m2' ; evm := vm2 |} & match_mem m2 m2'. Proof. elim: xs vs scs1 vm1 m1 m1'. @@ -1297,7 +1292,7 @@ Section PROOF. (* Define where/how the return address is pass by the caller to the callee *) Definition value_of_ra (m: mem) - (vm: vmap) + (vm: Vm.t) (ra: return_address_location) (target: option (remote_label * lcmd * nat)) : Prop := @@ -1310,7 +1305,7 @@ Section PROOF. (caller, lbl) \in label_in_lprog p' & exists2 ptr, encode_label (label_in_lprog p') (caller, lbl) = Some ptr & - vm.[ra] = ok (pword_of_word (zero_extend ws ptr)) + vm.[ra] = Vword (zero_extend ws ptr) ] else False @@ -1321,7 +1316,7 @@ Section PROOF. (caller, lbl) \in label_in_lprog p' & exists2 ptr, encode_label (label_in_lprog p') (caller, lbl) = Some ptr & - vm.[ra] = ok (pword_of_word (zero_extend ws ptr)) + vm.[ra] = Vword (zero_extend ws ptr) ] else False @@ -1330,12 +1325,12 @@ Section PROOF. find_label lbl cbody = ok pc, (caller, lbl) \in label_in_lprog p' & exists2 ptr, encode_label (label_in_lprog p') (caller, lbl) = Some ptr & - exists2 sp, vm.[ vrsp ] = ok (pword_of_word sp) & read m (sp + wrepr Uptr ofs)%R Uptr = ok ptr + exists2 sp, vm.[ vrsp ] = Vword sp & read m (sp + wrepr Uptr ofs)%R Uptr = ok ptr ] | _, _ => False - end%vmap. + end. (* Export functions save and restore the contents of “to-save” registers. *) Definition is_callee_saved_of (fn: funname) (s: seq var) : Prop := @@ -1374,16 +1369,16 @@ Section PROOF. Qed. Lemma write_lval_preserves_metadata x v v' s s' t t' : - write_lval [::] x v s = ok s' → - write_lval [::] x v' t = ok t' → + write_lval true [::] x v s = ok s' → + write_lval true [::] x v' t = ok t' → escs s = escs t → - vm_uincl s t → + s <=1 t → match_mem s t → preserved_metadata (emem s) (emem t) (emem t'). Proof. case: x. - - move => /= _ ty /write_noneP[] <- _ /write_noneP[] -> _; reflexivity. - - move => x /write_var_emem -> /write_var_emem ->; reflexivity. + - move => /= _ ty /write_noneP[] <- _ _ /write_noneP[] -> _ _; reflexivity. + - move => x /write_var_memP -> /write_var_memP ->; reflexivity. - case: s t => scs m vm [] tscs tv tvm /=. move => sz x e ok_s' ok_t' E X M; subst tscs. move: ok_s' => /=; t_xrbindP => a xv ok_xv ok_a ofs ev ok_ev ok_ofs w ok_w m' ok_m' _{s'}. @@ -1413,10 +1408,10 @@ Section PROOF. Lemma write_lvals_preserves_metadata xs vs vs' s s' t t' : List.Forall2 value_uincl vs vs' → - write_lvals [::] s xs vs = ok s' → - write_lvals [::] t xs vs' = ok t' → + write_lvals true [::] s xs vs = ok s' → + write_lvals true [::] t xs vs' = ok t' → escs s = escs t → - vm_uincl s t → + s <=1 t → match_mem s t → preserved_metadata (emem s) (emem t) (emem t'). Proof. @@ -1459,28 +1454,26 @@ Section PROOF. Qed. (* ---------------------------------------------------- *) - Variant ex2_6 (T1 T2: Type) (A B C D E F : T1 → T2 → Prop) : Prop := - Ex2_6 x1 x2 of A x1 x2 & B x1 x2 & C x1 x2 & D x1 x2 & E x1 x2 & F x1 x2. + Variant ex2_5 (T1 T2: Type) (A B C D E : T1 → T2 → Prop) : Prop := + Ex2_5 x1 x2 of A x1 x2 & B x1 x2 & C x1 x2 & D x1 x2 & E x1 x2. Let Pi (k: Sv.t) (s1: estate) (i: instr) (s2: estate) : Prop := ∀ fn lbl, checked_i fn i → let: (lbli, li) := linear_i fn i lbl [::] in ∀ m1 vm1 P Q, - wf_vm vm1 → match_mem s1 m1 → - vm_uincl s1 vm1 → + s1 <=1 vm1 → disjoint_labels lbl lbli P → is_linear_of fn (P ++ li ++ Q) → - ex2_6 + ex2_5 (λ m2 vm2, lsem p' (Lstate (escs s1) m1 vm1 fn (size P)) (Lstate (escs s2) m2 vm2 fn (size (P ++ li))) ) - (λ _ vm2, vm1 = vm2 [\ k ]) - (λ _ vm2, wf_vm vm2) - (λ _ vm2, vm_uincl s2 vm2) + (λ _ vm2, vm1 =[\ k ] vm2 ) + (λ _ vm2, s2 <=1 vm2) (λ m2 _, preserved_metadata s1 m1 m2) (λ m2 _, match_mem s2 m2). @@ -1489,20 +1482,18 @@ Section PROOF. checked_i fn (MkI ii i) → let: (lbli, li) := linear_i fn (MkI ii i) lbl [::] in ∀ m1 vm1 P Q, - wf_vm vm1 → match_mem s1 m1 → - vm_uincl s1 vm1 → + s1 <=1 vm1 → disjoint_labels lbl lbli P → is_linear_of fn (P ++ li ++ Q) → - ex2_6 + ex2_5 (λ m2 vm2, lsem p' (Lstate (escs s1) m1 vm1 fn (size P)) (Lstate (escs s2) m2 vm2 fn (size (P ++ li))) ) - (λ _ vm2, vm1 = vm2 [\ k ]) - (λ _ vm2, wf_vm vm2) - (λ _ vm2, vm_uincl s2 vm2) + (λ _ vm2, vm1 =[\ k ] vm2 ) + (λ _ vm2, s2 <=1 vm2) (λ m2 _, preserved_metadata s1 m1 m2) (λ m2 _, match_mem s2 m2). @@ -1511,34 +1502,30 @@ Section PROOF. checked_c fn c → let: (lblc, lc) := linear_c fn c lbl [::] in ∀ m1 vm1 P Q, - wf_vm vm1 → match_mem s1 m1 → - vm_uincl s1 vm1 → + s1 <=1 vm1 → disjoint_labels lbl lblc P → is_linear_of fn (P ++ lc ++ Q) → - ex2_6 + ex2_5 (λ m2 vm2, lsem p' (Lstate (escs s1) m1 vm1 fn (size P)) (Lstate (escs s2) m2 vm2 fn (size (P ++ lc))) ) - (λ _ vm2, vm1 = vm2 [\ k ]) - (λ _ vm2, wf_vm vm2) - (λ _ vm2, vm_uincl s2 vm2) + (λ _ vm2, vm1 =[\ k ] vm2 ) + (λ _ vm2, s2 <=1 vm2) (λ m2 _, preserved_metadata s1 m1 m2) (λ m2 _, match_mem s2 m2). Let Pfun (ii: instr_info) (k: Sv.t) (s1: estate) (fn: funname) (s2: estate) : Prop := ∀ m1 vm1 body ra lret sp callee_saved, - wf_vm vm1 → match_mem s1 m1 → - vm_uincl - (kill_vars match ra with + (kill_vars match ra with | RAnone => Sv.singleton var_tmp | RAreg x => Sv.singleton x | RAstack (Some x) _ => Sv.singleton x | RAstack None _ => Sv.empty - end s1).[vrsp <- ok (pword_of_word sp)]%vmap vm1 → + end s1).[vrsp <- Vword sp] <=1 vm1 → is_linear_of fn body → (* RA contains a safe return address “lret” *) is_ra_of fn ra → @@ -1548,19 +1535,18 @@ Section PROOF. (* To-save variables are initialized in the initial linear state *) is_callee_saved_of fn callee_saved → vm_initialized_on vm1 callee_saved → - ex2_6 + ex2_5 (λ m2 vm2, if lret is Some ((caller, lbl), _cbody, pc) then lsem p' (Lstate (escs s1) m1 vm1 fn 1) (Lstate (escs s2) m2 vm2 caller pc.+1) else lsem p' (Lstate (escs s1) m1 vm1 fn 0) (Lstate (escs s2) m2 vm2 fn (size body))) - (λ _ vm2, vm1 = vm2 [\ match ra with - | RAnone => Sv.diff k (sv_of_list id callee_saved) - | RAreg _ => k - | RAstack _ _ => Sv.add vrsp k - end ]) - (λ _ vm2, wf_vm vm2) - (λ _ vm2, s2.[vrsp <- ok (pword_of_word (if ra is RAstack _ _ then sp + wrepr _ (wsize_size Uptr) - else sp))] <=[\ sv_of_list id callee_saved ] vm2) + (λ _ vm2, vm1 =[\ match ra with + | RAnone => Sv.diff k (sv_of_list id callee_saved) + | RAreg _ => k + | RAstack _ _ => Sv.add vrsp k + end ] vm2) + (λ _ vm2, s2.[vrsp <- Vword (if ra is RAstack _ _ then sp + wrepr _ (wsize_size Uptr) + else sp)] <=[\ sv_of_list id callee_saved ] vm2) (λ m2 _, preserved_metadata s1 m1 m2) (λ m2 _, match_mem s2 m2). @@ -1590,27 +1576,27 @@ Section PROOF. case: (linear_c fn) (valid_c fn c lbl) (hc fn lbl chk_c) => lblc lc [Lc Vc] Sc. rewrite linear_i_nil. case: linear_i (valid_i fn i lblc) (hi fn lblc chk_i) => lbli li [Li Vi] Si. - move => m1 vm1 P Q Wc Mc Xc Dc C. + move => m1 vm1 P Q Mc Xc Dc C. have D : disjoint_labels lblc lbli P. + apply: (disjoint_labels_wL _ Dc); exact: Lc. have C' : is_linear_of fn (P ++ li ++ lc ++ Q). + by move: C; rewrite !catA. - have [ m2 vm2 Ei Ki Wi Xi Hi Mi ] := Si m1 vm1 P (lc ++ Q) Wc Mc Xc D C'. + have [ m2 vm2 Ei Ki Xi Hi Mi ] := Si m1 vm1 P (lc ++ Q) Mc Xc D C'. have Di : disjoint_labels lbl lblc (P ++ li). + apply: disjoint_labels_cat. * apply: (disjoint_labels_wH _ Dc); exact: Li. apply: (valid_disjoint_labels Vi); lia. have Ci : is_linear_of fn ((P ++ li) ++ lc ++ Q). + by move: C; rewrite !catA. - have [ m3 vm3 ] := Sc m2 vm2 (P ++ li) Q Wi Mi Xi Di Ci. - rewrite -!catA => E K W X H M. - exists m3 vm3; [ | | exact: W | exact: X | | exact: M ]; cycle 2. + have [ m3 vm3 ] := Sc m2 vm2 (P ++ li) Q Mi Xi Di Ci. + rewrite -!catA => E K X H M. + exists m3 vm3; [ | | exact: X | | exact: M ]; cycle 2. + etransitivity; first exact: Hi. apply: preserved_metadataE H. + exact: sem_I_stack_stable exec_i. exact: sem_I_validw_stable exec_i. + exact: lsem_trans Ei E. - apply: vmap_eq_exceptT; apply: vmap_eq_exceptI. + apply: eq_exT; apply: eq_exI. 2: exact: Ki. 3: exact: K. all: SvD.fsetdec. @@ -1620,12 +1606,11 @@ Section PROOF. Proof. move => ii k i s1 s2 ok_fr h _ fn lbl chk. move: h => /(_ fn lbl chk); case: linear_i (valid_i fn (MkI ii i) lbl) => lbli li [L V] S. - move => m1 vm1 P Q W M X D C. - have {W M X} [m2 vm2 E K W X H M] := S _ vm1 _ _ W M X D C. + move => m1 vm1 P Q M X D C. + have {M X} [m2 vm2 E K X H M] := S _ vm1 _ _ M X D C. exists m2 vm2. - exact: E. - - apply: vmap_eq_exceptI K; SvD.fsetdec. - - exact: W. + - apply: eq_exI K; SvD.fsetdec. - exact: X. - exact: preserved_metadataE H. exact: M. @@ -1653,7 +1638,7 @@ Section PROOF. Lemma check_rexprsP ii es u : allM (check_rexpr ii) es = ok u → exists2 rs, oseq.omap rexpr_of_pexpr es = Some rs & - ∀ s vs, sem_pexprs [::] s es = ok vs → sem_rexprs s rs = ok vs. + ∀ s vs, sem_pexprs true [::] s es = ok vs → sem_rexprs s rs = ok vs. Proof. case: u; elim: es. - by move => _; exists [::]. @@ -1666,7 +1651,7 @@ Section PROOF. Lemma check_lexprsP ii xs u : allM (check_lexpr ii) xs = ok u → exists2 ds, oseq.omap lexpr_of_lval xs = Some ds & - ∀ s vs s', write_lvals [::] s xs vs = ok s' → write_lexprs ds vs s = ok s'. + ∀ s vs s', write_lvals true [::] s xs vs = ok s' → write_lexprs ds vs s = ok s'. Proof. case: u; elim: xs. - by move => _; exists [::]. @@ -1683,13 +1668,12 @@ Section PROOF. move => fn lbl /checked_iE[] fd ok_fd. rewrite /check_i; t_xrbindP => /check_rexprsP[] qs ok_qs chk_es /check_lexprsP[] ds ok_ds chk_xs. rewrite /= ok_ds ok_qs. - move => m1 vm1 P Q W1 M1 X1 D1 C1. + move => m1 vm1 P Q M1 X1 D1 C1. have [ vs' /(match_mem_sem_pexprs M1) /chk_es ok_vs' vs_vs' ] := sem_pexprs_uincl X1 ok_vs. have [ rs' ok_rs' rs_rs' ] := vuincl_exec_opn vs_vs' ok_rs. have [ vm2 /(match_mem_write_lvals M1) [ m2 ok_s2' M2 ] ok_vm2 ] := writes_uincl X1 rs_rs' ok_s2. - exists m2 vm2; [ | | | exact: ok_vm2 | | exact: M2 ]; last first. + exists m2 vm2; [ | | exact: ok_vm2 | | exact: M2 ]; last first. + exact: write_lvals_preserves_metadata ok_s2 ok_s2' _ X1 M1. - + exact: wf_write_lvals ok_s2'. + by have := vrvsP ok_s2'. apply: LSem_step. rewrite -(addn0 (size P)) /lsem1 /step /= (find_instr_skip C1) /= /eval_instr /to_estate /=. @@ -1701,21 +1685,20 @@ Section PROOF. get_vars_uincl_ -> get_vars_uincl introduce get_vars and get_vars_i *) - - Lemma get_vars_uincl_ (xs : seq var) (vm1 vm2 : vmap) (vs1 : seq value) : - vm_uincl vm1 vm2 → - mapM (get_var vm1) xs = ok vs1 → + Lemma get_vars_uincl_ (xs : seq var) (vm1 vm2 : Vm.t) (vs1 : seq value) : + vm1 <=1 vm2 → + mapM (get_var true vm1) xs = ok vs1 → exists2 vs2 : seq value, - mapM (get_var vm2) xs = ok vs2 & List.Forall2 value_uincl vs1 vs2. + mapM (get_var true vm2) xs = ok vs2 & List.Forall2 value_uincl vs1 vs2. Proof. move=> h1 h2; - have := get_vars_uincl (xs := map (fun x => {| v_var := x; v_info := dummy_var_info |}) xs) h1. + have := get_vars_uincl (wdb:=true) (xs := map (fun x => {| v_var := x; v_info := dummy_var_info |}) xs) h1. by rewrite !mapM_map => /(_ _ h2). Qed. Lemma vm_after_syscall_uincl vm1 vm2 : - vm_uincl vm1 vm2 -> - vm_uincl (vm_after_syscall vm1) (vm_after_syscall vm2). + vm1 <=1 vm2 -> + vm_after_syscall vm1 <=1 vm_after_syscall vm2. Proof. by move=> h x; rewrite /vm_after_syscall !kill_varsE; case: ifP. Qed. @@ -1742,7 +1725,7 @@ Section PROOF. have [[[ _ rm' ] _ ] -> /= [] <- <-]:= mk_forall_exP h happ; by eexists. Qed. - Lemma syscall_killP vm : vm = vm_after_syscall vm [\syscall_kill]. + Lemma syscall_killP vm : vm =[\syscall_kill] vm_after_syscall vm. Proof. by move=> x /Sv_memP /negPf; rewrite /vm_after_syscall kill_varsE => ->. Qed. Lemma preserved_metadata_fill_mem m0 m1 m2 m m' ptr bytes : @@ -1785,7 +1768,7 @@ Section PROOF. Local Lemma Hsyscall : sem_Ind_syscall p Pi_r. Proof. move=> ii s1 s2 o xs es scs m ves vs hes ho hw fn lbl /checked_iE [] fd ok_fd chk. - move => m1 vm1 P Q W1 M1 X1 D1 C1. + move => m1 vm1 P Q M1 X1 D1 C1. have [ves' hes' uves]:= get_vars_uincl_ X1 hes. have [vs' /= ho' uvs]:= exec_syscallP ho uves. have [m' {ho'}ho' mm]:= match_mem_exec_syscall M1 ho'. @@ -1795,10 +1778,9 @@ Section PROOF. + apply: LSem_step. rewrite -(addn0 (size P)) /lsem1 /step /= (find_instr_skip C1) /= /eval_instr /to_estate /=. by rewrite hes' /= ho' /= ok_s2' /= size_cat addn0 addn1. - + apply: (vmap_eq_exceptT (vm2 := vm_after_syscall vm1)). - + by apply: vmap_eq_exceptI (syscall_killP vm1); SvD.fsetdec. - by apply: vmap_eq_exceptI; last apply: vrvsP ok_s2'; SvD.fsetdec. - + by apply: wf_write_lvals ok_s2'; apply wf_kill_vars. + + apply: (eq_exT (vm2 := vm_after_syscall vm1)). + + by apply: eq_exI (syscall_killP vm1); SvD.fsetdec. + by apply: eq_exI; last apply: vrvsP ok_s2'; SvD.fsetdec. rewrite p_globs_nil in hw ok_s2'. have /= := write_lvals_preserves_metadata uvs hw ok_s2' erefl (vm_after_syscall_uincl X1) mm. by apply: preserved_metadata_syscall uves ho ho'. @@ -1829,10 +1811,10 @@ Section PROOF. + case/semE: E1 => hk ?; subst s2. rewrite /= linear_c_nil; case: (linear_c fn) (valid_c fn c2 (next_lbl lbl)) => lbl2 lc2. rewrite /next_lbl => - [L V]. - move => m1 vm1 P Q W1 M1 X1 D C1. + move => m1 vm1 P Q M1 X1 D C1. have [ b /(match_mem_sem_pexpr M1) ok_e' /value_uinclE ? ] := sem_pexpr_uincl X1 ok_e; subst b. have {} ok_e' := fexpr_of_pexprP ok_f ok_e'. - exists m1 vm1; [ | | exact: W1 | exact: X1 | by [] | exact: M1 ]; last by []. + exists m1 vm1; [ | | exact: X1 | by [] | exact: M1 ]; last by []. apply: LSem_step. rewrite /lsem1 /step -(addn0 (size P)) (find_instr_skip C1) /= /eval_instr /to_estate /li_i (eval_jumpE C1) /to_estate /= ok_e' /=. rewrite find_label_cat_hd; last by apply: D; lia. @@ -1845,7 +1827,7 @@ Section PROOF. rewrite ok_nf. case: (linear_c fn) (Hc1 fn (next_lbl lbl)) => lbl1 lc1. rewrite /checked_c ok_fd chk_c1 => /(_ erefl) S. - move => m1 vm1 P Q W1 M1 X1 D C1. + move => m1 vm1 P Q M1 X1 D C1. set P' := rcons P (MkLI ii (Lcond nf lbl)). have D' : disjoint_labels (next_lbl lbl) lbl1 P'. - rewrite /P' -cats1; apply: disjoint_labels_cat; last by []. @@ -1853,9 +1835,9 @@ Section PROOF. set Q' := MkLI ii (Llabel lbl) :: Q. have C' : is_linear_of fn (P' ++ lc1 ++ Q'). - by move: C1; rewrite /P' /Q' -cats1 /= -!catA. - have {S} [ m2 vm2 E K2 W2 X2 H2 M2 ] := S m1 vm1 P' Q' W1 M1 X1 D' C'. + have {S} [ m2 vm2 E K2 X2 H2 M2 ] := S m1 vm1 P' Q' M1 X1 D' C'. have [ b /(match_mem_sem_pexpr M1) ok_e' /value_uinclE ? ] := sem_pexpr_uincl X1 ok_e; subst b. - exists m2 vm2; [ | exact: K2 | exact: W2 | exact: X2 | exact: H2 | exact: M2 ]. + exists m2 vm2; [ | exact: K2 | exact: X2 | exact: H2 | exact: M2 ]. apply: lsem_step; last apply: lsem_trans. 2: exact: E. - have /= := snot_spec ok_e'. @@ -1871,7 +1853,7 @@ Section PROOF. rewrite /checked_c ok_fd chk_c1 => /(_ erefl) E. rewrite linear_c_nil. case: (linear_c fn) (valid_c fn (i2 :: c2) lbl1) => lbl2 lc2 [L2 V2]. - move => m1 vm1 P Q W1 M1 X1 D C. + move => m1 vm1 P Q M1 X1 D C. have [ b /(match_mem_sem_pexpr M1) ok_e' /value_uinclE ? ] := sem_pexpr_uincl X1 ok_e; subst b. set P' := P ++ {| li_ii := ii; li_i := Lcond f lbl |} :: lc2 ++ [:: {| li_ii := ii; li_i := Lgoto (fn, (lbl + 1)%positive) |}; {| li_ii := ii; li_i := Llabel lbl |} ]. have D' : disjoint_labels (lbl + 1 + 1) lbl1 P'. @@ -1881,8 +1863,8 @@ Section PROOF. set Q' := {| li_ii := ii; li_i := Llabel (lbl + 1) |} :: Q. have C' : is_linear_of fn (P' ++ lc1 ++ Q'). + by move: C; rewrite /P' /Q' /= -!catA /= -!catA. - have {E} [ m2 vm2 E K2 W2 X2 H2 M2 ] := E m1 vm1 P' Q' W1 M1 X1 D' C'. - exists m2 vm2; [ | exact: K2 | exact: W2 | exact: X2 | exact: H2 | exact: M2 ]. + have {E} [ m2 vm2 E K2 X2 H2 M2 ] := E m1 vm1 P' Q' M1 X1 D' C'. + exists m2 vm2; [ | exact: K2 | exact: X2 | exact: H2 | exact: M2 ]. apply: lsem_step; last apply: lsem_trans. 2: exact: E. - have {} ok_e' := fexpr_of_pexprP ok_f ok_e'. @@ -1906,7 +1888,7 @@ Section PROOF. + rewrite linear_c_nil. case: (linear_c fn) (Hc2 fn (next_lbl lbl)) => lbl2 lc2. rewrite /checked_c ok_fd chk_c2 => /(_ erefl) S. - move => m1 vm1 P Q W1 M1 X1 D C. + move => m1 vm1 P Q M1 X1 D C. set P' := rcons P (MkLI ii (Lcond f lbl)). have D' : disjoint_labels (next_lbl lbl) lbl2 P'. - rewrite /P' -cats1; apply: disjoint_labels_cat; last by []. @@ -1914,9 +1896,9 @@ Section PROOF. set Q' := MkLI ii (Llabel lbl) :: Q. have C' : is_linear_of fn (P' ++ lc2 ++ Q'). - by move: C; rewrite /P' /Q' -cats1 /= -!catA. - have {S} [ m2 vm2 E K2 W2 X2 H2 M2 ] := S m1 vm1 P' Q' W1 M1 X1 D' C'. + have {S} [ m2 vm2 E K2 X2 H2 M2 ] := S m1 vm1 P' Q' M1 X1 D' C'. have [ b /(match_mem_sem_pexpr M1) ok_e' /value_uinclE ? ] := sem_pexpr_uincl X1 ok_e; subst b. - exists m2 vm2; [ | exact: K2 | exact: W2 | exact: X2 | exact: H2 | exact: M2 ]. + exists m2 vm2; [ | exact: K2 | exact: X2 | exact: H2 | exact: M2 ]. apply: lsem_step; last apply: lsem_trans. 2: exact: E. - have {} ok_e' := fexpr_of_pexprP ok_f ok_e'. @@ -1930,9 +1912,9 @@ Section PROOF. rewrite ok_nf. rewrite linear_c_nil; case: (linear_c fn) (valid_c fn (i1 :: c1) (next_lbl lbl)) => lbl1 lc1. rewrite /next_lbl => - [L V]. - move => m1 vm1 P Q W1 M1 X1 D C. + move => m1 vm1 P Q M1 X1 D C. have [ b /(match_mem_sem_pexpr M1) ok_e' /value_uinclE ? ] := sem_pexpr_uincl X1 ok_e; subst b. - exists m1 vm1; [ | | exact: W1 | exact: X1 | by [] | exact: M1 ]; last by []. + exists m1 vm1; [ | | exact: X1 | by [] | exact: M1 ]; last by []. apply: LSem_step. have /= := snot_spec ok_e'. rewrite ok_e' => /(fexpr_of_pexprP ok_nf) {} ok_e'. @@ -1948,7 +1930,7 @@ Section PROOF. rewrite linear_c_nil. case: (linear_c fn) (valid_c fn (i2 :: c2) lbl1) (Hc2 fn lbl1) => lbl2 lc2 [L2 V2]. rewrite /checked_c ok_fd chk_c2 => /(_ erefl) E. - move => m1 vm1 P Q W1 M1 X1 D C. + move => m1 vm1 P Q M1 X1 D C. have [ b /(match_mem_sem_pexpr M1) ok_e' /value_uinclE ? ] := sem_pexpr_uincl X1 ok_e; subst b. set P' := rcons P {| li_ii := ii; li_i := Lcond f lbl |}. have D' : disjoint_labels lbl1 lbl2 P'. @@ -1957,8 +1939,8 @@ Section PROOF. set Q' := {| li_ii := ii; li_i := Lgoto (fn, (lbl + 1)%positive) |} :: {| li_ii := ii; li_i := Llabel lbl |} :: lc1 ++ [:: {| li_ii := ii; li_i := Llabel (lbl + 1) |}]. have C' : is_linear_of fn (P' ++ lc2 ++ Q' ++ Q). + by move: C; rewrite /P' /Q' /= -cats1 /= -!catA /= -!catA. - have {E} [ m2 vm2 E K2 W2 X2 H2 M2 ] := E m1 vm1 P' (Q' ++ Q) W1 M1 X1 D' C'. - exists m2 vm2; [ | exact: K2 | exact: W2 | exact: X2 | exact: H2 | exact: M2 ]. + have {E} [ m2 vm2 E K2 X2 H2 M2 ] := E m1 vm1 P' (Q' ++ Q) M1 X1 D' C'. + exists m2 vm2; [ | exact: K2 | exact: X2 | exact: H2 | exact: M2 ]. apply: lsem_step; last apply: lsem_trans. 2: exact: E. + have {} ok_e' := fexpr_of_pexprP ok_f ok_e'. @@ -2053,16 +2035,16 @@ Section PROOF. rewrite /checked_c ok_fd ok_c => /(_ erefl). case: (linear_c fn c lblc' [::]) (valid_c fn c lblc') => lblc lc [L V] Hc /= Hw. rewrite add_align_nil. - move => m vm P Q W M X D C. - have {Hc} := Hc m vm (P ++ add_align ii a [::] ++ [:: ι (Llabel lbl) ]) (lc' ++ [:: ι (Lgoto (fn, lbl)) ] ++ Q) W M X. + move => m vm P Q M X D C. + have {Hc} := Hc m vm (P ++ add_align ii a [::] ++ [:: ι (Llabel lbl) ]) (lc' ++ [:: ι (Lgoto (fn, lbl)) ] ++ Q) M X. case. - apply: disjoint_labels_cat; last apply: disjoint_labels_cat. + apply: disjoint_labels_wL D; lia. + by case: (a). move => lbl' range; rewrite /is_label /= orbF; apply/eqP; lia. - by move: C; rewrite -!/(ι _) /= -!catA /= -!catA cat1s. - move => m1 vm1 E1 K1 W1 X1 H1 M1. - have {Hc'} := Hc' m1 vm1 ((P ++ add_align ii a [::] ++ [:: ι (Llabel lbl) ]) ++ lc) ([:: ι (Lgoto (fn, lbl)) ] ++ Q) W1 M1 X1. + move => m1 vm1 E1 K1 X1 H1 M1. + have {Hc'} := Hc' m1 vm1 ((P ++ add_align ii a [::] ++ [:: ι (Llabel lbl) ]) ++ lc) ([:: ι (Lgoto (fn, lbl)) ] ++ Q) M1 X1. case. - repeat apply: disjoint_labels_cat. + apply: disjoint_labels_w D; lia. @@ -2070,15 +2052,15 @@ Section PROOF. + move => lbl' range; rewrite /is_label /= orbF; apply/eqP; lia. apply: (valid_disjoint_labels V); left; lia. - by move: C; rewrite /= -!catA /= -!catA. - move => m2 vm2 E2 K2 W2 X2 H2 M2. - have {Hw} := Hw m2 vm2 P Q W2 M2 X2 D. + move => m2 vm2 E2 K2 X2 H2 M2. + have {Hw} := Hw m2 vm2 P Q M2 X2 D. case. - by rewrite add_align_nil. - move => m3 vm3 E3 K3 W3 X3 H3 M3. - exists m3 vm3; [ | | exact: W3 | exact: X3 | | exact: M3 ]; cycle 1. - - transitivity vm2; last (apply: vmap_eq_exceptI K3; SvD.fsetdec). - transitivity vm1; last (apply: vmap_eq_exceptI K2; SvD.fsetdec). - apply: vmap_eq_exceptI K1; SvD.fsetdec. + move => m3 vm3 E3 K3 X3 H3 M3. + exists m3 vm3; [ | | exact: X3 | | exact: M3 ]; cycle 1. + - transitivity vm2; last (apply: eq_exI K3; SvD.fsetdec). + transitivity vm1; last (apply: eq_exI K2; SvD.fsetdec). + apply: eq_exI K1; SvD.fsetdec. - etransitivity; first exact: H1. apply: preserved_metadataE; last (etransitivity; first exact: H2); last first. + apply: preserved_metadataE; last exact: H3. @@ -2133,23 +2115,23 @@ Section PROOF. case: (linear_c fn c (next_lbl lbl) [::]) (valid_c fn c (next_lbl lbl)) => lblc lc. rewrite /next_lbl => - [L V] Hc /= /(_ erefl) Hw. rewrite add_align_nil. - move => m vm P Q W M X D C. - have {Hc} := Hc m vm (P ++ add_align ii a [::] ++ [:: ι (Llabel lbl) ]) ([:: ι (Lcond f lbl) ] ++ Q) W M X. + move => m vm P Q M X D C. + have {Hc} := Hc m vm (P ++ add_align ii a [::] ++ [:: ι (Llabel lbl) ]) ([:: ι (Lcond f lbl) ] ++ Q) M X. case. - apply: disjoint_labels_cat; last apply: disjoint_labels_cat. + apply: disjoint_labels_wL D; rewrite /next_lbl; lia. + by case: (a). rewrite /next_lbl => lbl' range; rewrite /is_label /= orbF; apply/eqP; lia. - by move: C; rewrite -!/(ι _) /= -!catA /= -!catA. - move => m1 vm1 E1 K1 W1 X1 H1 M1. + move => m1 vm1 E1 K1 X1 H1 M1. have [ b /(match_mem_sem_pexpr M1) {} ok_e /value_uinclE ? ] := sem_pexpr_uincl X1 ok_e; subst b. - have {Hw} := Hw m1 vm1 P Q W1 M1 X1 D. + have {Hw} := Hw m1 vm1 P Q M1 X1 D. case. - by rewrite add_align_nil. - move => m3 vm3 E3 K3 W3 X3 H3 M3. - exists m3 vm3; [ | | exact: W3 | exact: X3 | | exact: M3 ]; cycle 1. - - transitivity vm1; last (apply: vmap_eq_exceptI K3; SvD.fsetdec). - apply: vmap_eq_exceptI K1; SvD.fsetdec. + move => m3 vm3 E3 K3 X3 H3 M3. + exists m3 vm3; [ | | exact: X3 | | exact: M3 ]; cycle 1. + - transitivity vm1; last (apply: eq_exI K3; SvD.fsetdec). + apply: eq_exI K1; SvD.fsetdec. - etransitivity; first exact: H1. apply: preserved_metadataE; last exact: H3. + exact: sem_stack_stable Ec. @@ -2200,8 +2182,8 @@ Section PROOF. rewrite /checked_c ok_fd ok_c' => /(_ erefl). case: (linear_c fn (i :: c') lblc [::]) (valid_c fn (i :: c') lblc) => lblc' lc' [L' V'] Hc' /= /(_ erefl) Hw. rewrite add_align_nil. - move => m vm P Q W M X D C. - have {Hc} := Hc m vm (P ++ ι (Lgoto (fn, lbl)) :: add_align ii a [::] ++ [:: ι (Llabel (lbl + 1)) ] ++ lc' ++ [:: ι (Llabel lbl) ]) ([:: ι (Lcond f (lbl + 1)) ] ++ Q) W M X. + move => m vm P Q M X D C. + have {Hc} := Hc m vm (P ++ ι (Lgoto (fn, lbl)) :: add_align ii a [::] ++ [:: ι (Llabel (lbl + 1)) ] ++ lc' ++ [:: ι (Llabel lbl) ]) ([:: ι (Lcond f (lbl + 1)) ] ++ Q) M X. case. - apply: disjoint_labels_cat; last apply: disjoint_labels_cat. + apply: disjoint_labels_w D; lia. @@ -2211,24 +2193,24 @@ Section PROOF. + apply: (valid_disjoint_labels V'); left; lia. move => lbl' range; rewrite /is_label /= orbF; apply/eqP; lia. - move: C; rewrite -!/(ι _) /= -!catA -!cat_cons -!catA -(cat1s _ lc) -(cat1s _ Q); exact. - move => m1 vm1 E1 K1 W1 X1 H1 M1. + move => m1 vm1 E1 K1 X1 H1 M1. have [ b /(match_mem_sem_pexpr M1) {} ok_e /value_uinclE ? ] := sem_pexpr_uincl X1 ok_e; subst b. - have {Hc'} := Hc' m1 vm1 (P ++ ι (Lgoto (fn, lbl)) :: add_align ii a [::] ++ [:: ι (Llabel (lbl + 1)) ]) (ι (Llabel lbl) :: lc ++ ι (Lcond f (lbl + 1)) :: Q) W1 M1 X1. + have {Hc'} := Hc' m1 vm1 (P ++ ι (Lgoto (fn, lbl)) :: add_align ii a [::] ++ [:: ι (Llabel (lbl + 1)) ]) (ι (Llabel lbl) :: lc ++ ι (Lcond f (lbl + 1)) :: Q) M1 X1. case. - apply: disjoint_labels_cat; last apply: disjoint_labels_cat. + apply: disjoint_labels_wL D; lia. + by case: (a). move => lbl' range; rewrite /is_label /= orbF; apply/eqP; lia. - move: C; rewrite -!/(ι _) /= -!catA -!cat_cons -(cat1s _ Q) -(cat1s _ lc') -!catA; exact. - move => m2 vm2 E2 K2 W2 X2 H2 M2. - have {Hw} := Hw m2 vm2 P Q W2 M2 X2 D. + move => m2 vm2 E2 K2 X2 H2 M2. + have {Hw} := Hw m2 vm2 P Q M2 X2 D. case. - by rewrite add_align_nil. - move => m3 vm3 E3 K3 W3 X3 H3 M3. - exists m3 vm3; [ | | exact: W3 | exact: X3 | | exact: M3 ]; cycle 1. - - transitivity vm2; last (apply: vmap_eq_exceptI K3; SvD.fsetdec). - transitivity vm1; last (apply: vmap_eq_exceptI K2; SvD.fsetdec). - apply: vmap_eq_exceptI K1; SvD.fsetdec. + move => m3 vm3 E3 K3 X3 H3 M3. + exists m3 vm3; [ | | exact: X3 | | exact: M3 ]; cycle 1. + - transitivity vm2; last (apply: eq_exI K3; SvD.fsetdec). + transitivity vm1; last (apply: eq_exI K2; SvD.fsetdec). + apply: eq_exI K1; SvD.fsetdec. - etransitivity; first exact: H1. apply: preserved_metadataE; last (etransitivity; first exact: H2); last first. + apply: preserved_metadataE; last exact: H3. @@ -2291,10 +2273,10 @@ Section PROOF. rewrite /checked_c ok_fd ok_c => /(_ erefl). case: (linear_c fn c lbl [::]) => lblc lc. move => Hc. - move => m vm P Q W M X D C. - have {Hc} [ m' vm' E K W' X' H' M' ] := Hc m vm P Q W M X D C. - exists m' vm'; [ exact: E | | exact: W' | exact: X' | exact: H' | exact: M' ]. - apply: vmap_eq_exceptI K; SvD.fsetdec. + move => m vm P Q M X D C. + have {Hc} [ m' vm' E K X' H' M' ] := Hc m vm P Q M X D C. + exists m' vm'; [ exact: E | | exact: X' | exact: H' | exact: M' ]. + apply: eq_exI K; SvD.fsetdec. } (* arbitrary expression *) t_xrbindP => {} e ok_e /check_fexprP[] f ok_f ok_c ok_c'. @@ -2307,13 +2289,13 @@ Section PROOF. case: (linear_c fn c (next_lbl lbl) [::]) => lblc lc. move => Hc. rewrite /= add_align_nil. - move => m vm P Q W M X D. + move => m vm P Q M X D. rewrite -cat1s !catA. set prefix := (X in X ++ lc). do 2 rewrite -catA. set suffix := (X in lc ++ X). move => C. - have {Hc} [ | m' vm' E K W' X' H' M' ] := Hc m vm prefix suffix W M X _ C. + have {Hc} [ | m' vm' E K X' H' M' ] := Hc m vm prefix suffix M X _ C. - apply: disjoint_labels_cat; first apply: disjoint_labels_cat. + apply: disjoint_labels_wL _ D; rewrite /next_lbl; lia. + by case: (a). @@ -2322,8 +2304,8 @@ Section PROOF. rewrite /is_label /= orbF; apply/eqP; lia. have [ ] := sem_pexpr_uincl X' ok_e. case => // - [] // /(match_mem_sem_pexpr M') {} ok_e _. - exists m' vm'; [ | | exact: W' | exact: X' | exact: H' | exact: M' ]; last first. - - apply: vmap_eq_exceptI K; SvD.fsetdec. + exists m' vm'; [ | | exact: X' | exact: H' | exact: M' ]; last first. + - apply: eq_exI K; SvD.fsetdec. apply: lsem_trans; last apply: (lsem_trans E). - apply: (lsem_trans (s2 := {| lpc := size (P ++ add_align ii a [::]); |})). @@ -2351,13 +2333,13 @@ Section PROOF. rewrite linear_c_nil. case: (linear_c fn (i :: c') lblc [::]) (valid_c fn (i :: c') lblc) => lblc' lc' [L' V']. rewrite /= add_align_nil. - move => m vm P Q W M X D. + move => m vm P Q M X D. rewrite -cat1s -(cat1s _ (lc' ++ _)) -(cat1s _ (lc ++ _)) !catA. set prefix := (X in X ++ lc). do 2 rewrite -catA. set suffix := (X in lc ++ X). move => C. - have {Hc} [ | m' vm' E K W' X' H' M' ] := Hc m vm prefix suffix W M X _ C. + have {Hc} [ | m' vm' E K X' H' M' ] := Hc m vm prefix suffix M X _ C. - subst prefix; move: L' V' D; clear. rewrite /next_lbl => L' V' D. repeat apply: disjoint_labels_cat; try by []. @@ -2368,8 +2350,8 @@ Section PROOF. move => lbl' range; rewrite /is_label /= orbF; apply/eqP; lia. have [ ] := sem_pexpr_uincl X' ok_e. case => // - [] // /(match_mem_sem_pexpr M') {} ok_e _. - exists m' vm'; [ | | exact: W' | exact: X' | exact: H' | exact: M' ]; last first. - - apply: vmap_eq_exceptI K; SvD.fsetdec. + exists m' vm'; [ | | exact: X' | exact: H' | exact: M' ]; last first. + - apply: eq_exI K; SvD.fsetdec. apply: lsem_trans; last apply: (lsem_trans E). - (* goto *) apply: LSem_step. @@ -2436,7 +2418,7 @@ Section PROOF. Proof. move => ii k s1 s2 ini res fn' args xargs xres ok_xargs ok_xres exec_call ih fn lbl /checked_iE[] fd ok_fd chk_call. case linear_eq: linear_i => [lbli li]. - move => m1 vm2 P Q W M X D C. + move => m1 vm2 P Q M X D C. move: chk_call => /=. t_xrbindP => /negbTE fn'_neq_fn. case ok_fd': (get_fundef _ fn') => [ fd' | ] //; t_xrbindP => ok_ra ok_align _. @@ -2448,7 +2430,7 @@ Section PROOF. t_xrbindP => chk_body ok_to_save ok_stk_sz ok_ret_addr ok_save_stack _. have ok_body' : is_linear_of fn' (lfd_body lfd'.2). - by rewrite /is_linear_of; eauto. - move: ih; rewrite /Pfun; move => /(_ _ _ _ _ _ _ _ _ _ _ ok_body') ih A. + move: ih; rewrite /Pfun; move => /(_ _ _ _ _ _ _ _ _ _ ok_body') ih A. have lbl_valid : (fn, lbl) \in (label_in_lprog p'). - clear -A C ok_ra hliparams. apply: (label_in_lfundef _ C). @@ -2459,7 +2441,7 @@ Section PROOF. assert (h := encode_label_dom small_dom_p' lbl_valid). case ok_ptr: encode_label h => [ ptr | // ] _. - case/sem_callE: (exec_call) => ? m s' k' args' res'; rewrite ok_fd' => /Some_inj <- ra_sem ok_ss sp_aligned T ok_m ok_args' wt_args' exec_cbody ok_res' wt_res' T' s2_eq. + case/sem_callE: (exec_call) => ? m s' k'; rewrite ok_fd' => /Some_inj <- ra_sem ok_ss sp_aligned T ok_m exec_cbody T' s2_eq. rewrite /ra_valid in ra_sem. rewrite /top_stack_aligned in sp_aligned. rewrite /ra_vm. @@ -2473,21 +2455,19 @@ Section PROOF. set after := allocate_stack_frame _ _ _ _ _ rastack_after. move: C; set P' := P ++ _ => C. set vm2_b := - if sz_before == 0%Z then vm2 else (vm2.[vrsp <- ok (pword_of_word (top_stack (emem s1) - wrepr Uptr sz_before))])%vmap. + if sz_before == 0%Z then vm2 else (vm2.[vrsp <- Vword (top_stack (emem s1) - wrepr Uptr sz_before)]). move: (X vrsp); rewrite T. - case vm2_rsp: vm2.[_]%vmap => [ top_ptr | // ] /= /pword_of_word_uincl[]. - case: top_ptr vm2_rsp => ? ? le_refl vm2_rsp /= ? ?; subst. + move=> /get_word_uincl_eq -/(_ (subtype_refl _)) vm2_rsp. have h1 : lsem p' (Lstate (escs s1) m1 vm2 fn (size P)) (Lstate (escs s1) m1 vm2_b fn (size P + size before)). + move: C ; rewrite /P' /vm2_b /before /sz_before /rastack_before /allocate_stack_frame /sz; case: eqP => _ C /=. + by rewrite addn0; apply rt_refl. apply LSem_step; rewrite /lsem1 /step -(addn0 (size P)) (find_instr_skip C) /= addn0 addn1. - apply (spec_lip_allocate_stack_frame + by apply (spec_lip_allocate_stack_frame hliparams _ _ (s := {| emem := _; evm := _; |})). - by rewrite /= vm2_rsp pword_of_wordE. set r := sf_return_address (f_extra fd'). set o := Some ((fn, lbl), P', (size P + size before).+1). set s := (top_stack (emem s1) - wrepr Uptr sz)%R. @@ -2497,15 +2477,15 @@ Section PROOF. | RAreg ra => Some (mk_var_i ra) | RAstack ra _ => mk_ovar_i ra end. - have vm2_b_upd : Fv.ext_eq vm2_b vm2.[vrsp <- ok (pword_of_word (top_stack (emem s1) - wrepr Uptr sz_before))]%vmap. - + move=> x; rewrite /vm2_b Fv.setP; case: eqP => [ | /eqP] *. - + subst x; case: eqP => [-> | ?]; last by rewrite Fv.setP_eq. - by rewrite wrepr0 GRing.subr0 vm2_rsp pword_of_wordE. - by case: eqP => // _; rewrite Fv.setP_neq. - have [m' [vm' [hwf_vm hmatch [hvm'_rsp heq_vm'] [hvalue_of hpres_m1_m'] h2]]] : exists m' vm', - [/\ wf_vm vm', match_mem s1 m', - vm'.[vrsp]%vmap = ok (pword_of_word s) /\ - vm2 = vm' [\ Sv.add vrsp (if ra is Some x then Sv.singleton x else Sv.empty)], + have vm2_b_upd : vm2_b =1 vm2.[vrsp <- Vword (top_stack (emem s1) - wrepr Uptr sz_before)]. + + move=> x; rewrite /vm2_b Vm.setP; case: (vrsp =P x) => [ | /eqP] *. + + subst x; case: eqP => [-> | ?]; last by rewrite Vm.setP_eq. + by rewrite wrepr0 GRing.subr0 vm_truncate_val_eq //. + by case: eqP => //; rewrite Vm.setP_neq. + have [m' [vm' [hmatch [hvm'_rsp heq_vm'] [hvalue_of hpres_m1_m'] h2]]] : exists m' vm', + [/\ match_mem s1 m', + vm'.[vrsp] = Vword s /\ + vm2 =[\ Sv.add vrsp (if ra is Some x then Sv.singleton x else Sv.empty)] vm' , value_of_ra m' vm' r o /\ preserved_metadata s1 m1 m' & eval_instr p' {| li_ii := ii; li_i := Lcall ra (fn', 1%positive) |} {| lscs := escs s1; lmem := m1; lvm := vm2_b; lfn := fn; lpc := size P + size before |} = @@ -2515,44 +2495,36 @@ Section PROOF. Some {| li_ii := ii; li_i := linear.Llabel ExternalLabel lbl |}. + by rewrite -addn1 -addnA (find_instr_skip C) -/before -catA oseq.onth_cat ltnNge addn1 leqnSn /= subSnn. rewrite ok_ptr ok_lfd' /= find_entry_label /=; last by apply/eqP. - have wf_vm2_b : wf_vm vm2_b. - + by rewrite /vm2_b; case: eqP => // _; apply wf_vm_set. - have wf_set_vm : forall x, vtype x == sword Uptr -> wf_vm (vm2_b.[x <- pof_val (vtype x) (Vword ptr)])%vmap. - + move=> x hx y; rewrite Fv.setP; case: eqP => ?; last by apply wf_vm2_b. - by subst; move/eqP: hx => ->. - rewrite sumbool_of_boolET. have hfind : find_label lbl P' = ok (size P + size before).+1. + rewrite /P' find_label_cat_hd; last by apply: D; rewrite /next_lbl; Psatz.lia. rewrite -catA find_label_cat_hd; last by rewrite /allocate_stack_frame; case: eqP => //. by rewrite /find_label /is_label /= eqxx /= addn1 addnS. case eq_ra : sf_return_address ok_ra ok_ret_addr ra_sem sp_aligned => [ | x | [ x | ] ofs] // _ ok_ret_addr ra_sem sp_aligned. (* RAreg x *) - + exists m1, vm2_b.[x <- pof_val (vtype x) (Vword ptr)]%vmap; split => //. - + by apply wf_set_vm. + + exists m1, vm2_b.[x <- Vword ptr]; split => //. + split. - + rewrite Fv.setP_neq; last by case/and3P : ra_sem. - by rewrite vm2_b_upd Fv.setP_eq /sz_before /rastack_before eq_ra. - move=> /= y hy; rewrite Fv.setP_neq; last by apply/eqP; move: hy; clear; SvD.fsetdec. - by rewrite vm2_b_upd Fv.setP_neq //; apply/eqP; move: hy; clear; SvD.fsetdec. + + rewrite Vm.setP_neq; last by case/and3P : ra_sem. + by rewrite vm2_b_upd Vm.setP_eq /sz_before /rastack_before eq_ra vm_truncate_val_eq. + move=> /= y hy; rewrite Vm.setP_neq; last by apply/eqP; move: hy; clear; SvD.fsetdec. + by rewrite vm2_b_upd Vm.setP_neq //; apply/eqP; move: hy; clear; SvD.fsetdec. + split => //. rewrite /value_of_ra. case: (x) ok_ret_addr => /= ? vra /eqP ->; rewrite eq_refl; split => //. - by rewrite ok_ptr; exists ptr => //; rewrite Fv.setP_eq /pof_val to_pword_u zero_extend_u. - by rewrite set_well_typed_var //=; apply/eqP. + by rewrite ok_ptr; exists ptr => //; rewrite Vm.setP_eq vm_truncate_val_eq // zero_extend_u. + by rewrite set_var_truncate //=; move/eqP: ok_ret_addr => ->. (* RAstack (Some x) ofs *) - + case/and4P: ok_ret_addr => /andP [] ok_ret_addr _ _ _ _. - exists m1, vm2_b.[x <- pof_val (vtype x) (Vword ptr)]%vmap; split => //. - + by apply wf_set_vm. + + case/and4P: ok_ret_addr => /andP [] /eqP ok_ret_addr _ _ _ _. + exists m1, vm2_b.[x <- Vword ptr]; split => //. + split. - + rewrite Fv.setP_neq; last by case/andP : ra_sem. - by rewrite vm2_b_upd Fv.setP_eq /sz_before /rastack_before eq_ra. - move=> /= y hy; rewrite Fv.setP_neq; last by apply/eqP; move: hy; clear; SvD.fsetdec. - by rewrite vm2_b_upd Fv.setP_neq //; apply/eqP; move: hy; clear; SvD.fsetdec. + + rewrite Vm.setP_neq; last by case/andP : ra_sem. + by rewrite vm2_b_upd Vm.setP_eq /sz_before /rastack_before eq_ra vm_truncate_val_eq. + move=> /= y hy; rewrite Vm.setP_neq; last by apply/eqP; move: hy; clear; SvD.fsetdec. + by rewrite vm2_b_upd Vm.setP_neq //; apply/eqP; move: hy; clear; SvD.fsetdec. + split => //. rewrite /value_of_ra. - case: (x) ok_ret_addr => /= ? vra /eqP ->; rewrite eq_refl; split => //. - by rewrite ok_ptr; exists ptr => //; rewrite Fv.setP_eq /pof_val to_pword_u zero_extend_u. - by rewrite /= set_well_typed_var //=; apply/eqP. + case: (x) ok_ret_addr => /= ? vra ->; rewrite eq_refl; split => //. + by rewrite ok_ptr; exists ptr => //; rewrite Vm.setP_eq zero_extend_u vm_truncate_val_eq. + by rewrite /= set_var_truncate //= ok_ret_addr. (* RAstack None ofs *) move: ok_ret_addr => /and4P [] _ /eqP ? /eqP hioff sf_align_for_ptr; subst ofs. have [m' ok_m' M']: @@ -2579,67 +2551,64 @@ Section PROOF. have {X} TmS := wunsigned_sub_small S_range X. rewrite TmS in above_limit. lia. - exists m', vm2_b.[vrsp <- ok (pword_of_word s)]%vmap; split => //. - + by apply wf_vm_set. - + split; first by rewrite Fv.setP_eq. - move=> /= y hy; rewrite Fv.setP_neq; last by apply/eqP; move: hy; clear; SvD.fsetdec. - by rewrite vm2_b_upd Fv.setP_neq //; apply/eqP; move: hy; clear; SvD.fsetdec. + exists m', vm2_b.[vrsp <- Vword s]; split => //. + + split; first by rewrite Vm.setP_eq vm_truncate_val_eq. + move=> /= y hy; rewrite Vm.setP_neq; last by apply/eqP; move: hy; clear; SvD.fsetdec. + by rewrite vm2_b_upd Vm.setP_neq //; apply/eqP; move: hy; clear; SvD.fsetdec. + split. + rewrite /value_of_ra /=; split => //. - rewrite ok_ptr; exists ptr => //; exists s; first by rewrite Fv.setP_eq. + rewrite ok_ptr; exists ptr => //; exists s; first by rewrite Vm.setP_eq vm_truncate_val_eq. move: ok_m'; rewrite /= wrepr0 GRing.addr0 top_stack_after_aligned_alloc // wrepr_opp. by apply writeP_eq. by apply: preserved_meta_store_top_stack ok_m ok_m' ok_stk_sz sp_aligned hioff. set s_ := (top_stack (emem s1) - wrepr Uptr sz_before)%R; rewrite lp_rspE. - have -> /= : Let x := get_var vm2_b vrsp in to_pointer x = ok s_. + have -> /= : Let x := get_var true vm2_b vrsp in to_pointer x = ok s_. + rewrite /vm2_b /s_; case: eqP => [-> | _]. - + by rewrite GRing.subr0 /get_var /= vm2_rsp /= truncate_word_u. - by rewrite /get_var /= Fv.setP_eq /= truncate_word_u. + + by rewrite GRing.subr0 /get_var /= vm2_rsp /= truncate_word_u. + by rewrite get_var_eq //= cmp_le_refl /= truncate_word_u. move: ok_m'; rewrite /s_ /sz_before /rastack_before eq_ra /= wrepr_sub. set ts := top_stack _. have -> : (ts - (wrepr Uptr sz - wrepr Uptr (wsize_size Uptr)) - wrepr Uptr (wsize_size Uptr))%R = (ts - wrepr Uptr sz)%R by ssrring.ssring. - by rewrite top_stack_after_aligned_alloc // wrepr_opp => -> /=; rewrite pword_of_wordE. - have huincl : vm_uincl - (kill_vars - match r with - | RAnone => Sv.singleton var_tmp - | RAreg x | RAstack (Some x) _ => Sv.singleton x - | RAstack None _ => Sv.empty - end s1).[vrsp <- ok (pword_of_word s)] vm'. - + move=> y; rewrite Fv.setP; case: eqP => heq; first by subst y; rewrite hvm'_rsp. + by rewrite top_stack_after_aligned_alloc // wrepr_opp => ->. + have huincl : + (kill_vars + match r with + | RAnone => Sv.singleton var_tmp + | RAreg x | RAstack (Some x) _ => Sv.singleton x + | RAstack None _ => Sv.empty + end s1).[vrsp <- Vword s] <=1 vm'. + + move=> y; rewrite Vm.setP; case: eqP => heq; first by subst y; rewrite hvm'_rsp vm_truncate_val_eq. rewrite /r kill_varsE; case: Sv_memP => hin. - + case: (vm'.[y])%vmap (hwf_vm y) => //. - + by move=> *; apply eval_uincl_undef. - by case => //; case: (vtype y). + + by apply/compat_value_uincl_undef/Vm.getP. rewrite -heq_vm' // /ra /r; move: heq hin; clear. by case: sf_return_address => [ | x | [x | ] ofs] /=; SvD.fsetdec. have his_ra: is_ra_of fn' r by exists fd'. - case (ih _ _ _ _ _ [::] hwf_vm hmatch huincl his_ra hvalue_of) => //. + case (ih _ _ _ _ _ [::] hmatch huincl his_ra hvalue_of) => //. + by rewrite /is_sp_for_call; exists fd' => //; case: sf_return_address sp_aligned ok_ra. + by rewrite /is_callee_saved_of; exists fd' => //; case: sf_return_address ok_ra. - move=> m2' vm2' /= h3 heq_vm hwf_vm' hsub_vm' hpres hmatch' hk. + move=> m2' vm2' /= h3 heq_vm hsub_vm' hpres hmatch' hk. set ts := top_stack (M := Memory.M) s1. - set vm2'_b := if sz_after == 0%Z then vm2' else vm2'.[vrsp <- ok (pword_of_word ts)]%vmap. + set vm2'_b := if sz_after == 0%Z then vm2' else vm2'.[vrsp <- Vword ts]. have vm2'_rsp: - vm2'.[vrsp]%vmap = ok (pword_of_word (s + wrepr Uptr (if rastack_after then wsize_size Uptr else 0%Z))). - + have /hsub_vm': ¬ Sv.In vrsp (sv_of_list id [::]). - + by rewrite /sv_of_list /=; SvD.fsetdec. - rewrite Fv.setP_eq /=; case: Fv.get => //= -[? ? le_refl'] /pword_of_word_uincl /= [e] ?; subst. - rewrite /rastack_after /r pword_of_wordE. - by case sf_return_address => //= *; rewrite wrepr0 GRing.addr0. - have vm2'_b_upd : Fv.ext_eq vm2'_b vm2'.[vrsp <- ok (pword_of_word ts)]. - + move=> y; rewrite Fv.setP; case: eqP => [ | /eqP] heq; - last by rewrite /vm2'_b; case: eqP => // _; rewrite Fv.setP_neq. - subst y; rewrite /vm2'_b; case: eqP => heq; last by rewrite Fv.setP_eq. + vm2'.[vrsp] = Vword (s + wrepr Uptr (if rastack_after then wsize_size Uptr else 0%Z)). + + have /hsub_vm': ¬ Sv.In vrsp (sv_of_list id [::]). + + by rewrite /sv_of_list /=; SvD.fsetdec. + rewrite Vm.setP_eq /= cmp_le_refl => /get_word_uincl_eq -/(_ (subtype_refl _)). + rewrite /rastack_after /r. + by case sf_return_address => //= *; rewrite wrepr0 GRing.addr0. + have vm2'_b_upd : vm2'_b =1 vm2'.[vrsp <- Vword ts]. + + move=> y; rewrite Vm.setP; case: eqP => [ | /eqP] heq; + last by rewrite /vm2'_b; case: eqP => // _; rewrite Vm.setP_neq. + subst y; rewrite /vm2'_b; case: eqP => heq; last by rewrite Vm.setP_eq. rewrite vm2'_rsp /s -/ts; do 2! f_equal. have -> : (ts - wrepr Uptr sz + wrepr Uptr (if rastack_after then wsize_size Uptr else 0%Z))%R = (ts - (wrepr Uptr sz_after))%R. + by rewrite /sz_after; case: (rastack_after); rewrite ?wrepr0 ?wrepr_sub; ssrring.ssring. - by rewrite heq wrepr0; ssrring.ssring. - apply (Ex2_6 (x1:=m2')(x2:=vm2'_b)). + by rewrite heq wrepr0 vm_truncate_val_eq // GRing.subr0. + apply (Ex2_5 (x1:=m2')(x2:=vm2'_b)). + apply/(lsem_trans h1)/lsem_step. + by rewrite /lsem1 /step (find_instr_skip C) -/before -catA oseq.onth_cat ltnn subnn /= h2. apply/(lsem_trans h3). @@ -2657,20 +2626,19 @@ Section PROOF. rewrite /of_estate /with_vm /=; do 5!f_equal. by rewrite /s /sz_after; case rastack_after; rewrite ?wrepr0 ?wrepr_sub; ssrring.ssring. + move => x x_notin_k. - rewrite vm2'_b_upd Fv.setP; case: eqP => x_neq_rsp. - * by subst; rewrite vm2_rsp pword_of_wordE. + rewrite vm2'_b_upd Vm.setP; case: eqP => x_neq_rsp. + * by subst; rewrite vm2_rsp vm_truncate_val_eq. rewrite -heq_vm. + apply heq_vm'. move: x_notin_k x_neq_rsp; rewrite hk /ra /r /=; clear. by case: sf_return_address => [ | r | [ r | ] ?] /=; SvD.fsetdec. by move: x_notin_k x_neq_rsp; clear; case: (r) => * //; rewrite /sv_of_list /=; SvD.fsetdec. - + by rewrite /vm2'_b; case: ifP => _ //; apply wf_vm_set. + have := sem_one_varmap_facts.sem_call_valid_RSP exec_call. rewrite /= /valid_RSP /set_RSP => h x /=. - rewrite vm2'_b_upd Fv.setP; case: eqP => [ | /eqP] *; first by subst x; rewrite h. - have := hsub_vm' x; rewrite Fv.setP_neq //; apply; rewrite /sv_of_list /=; clear; SvD.fsetdec. + rewrite vm2'_b_upd Vm.setP; case: eqP => [ | /eqP] *; first by subst x; rewrite h vm_truncate_val_eq. + have := hsub_vm' x; rewrite Vm.setP_neq //; apply; rewrite /sv_of_list /=; clear; SvD.fsetdec. + by etransitivity; eauto. exact hmatch'. - Qed. + Qed. Lemma RSP_in_magic : Sv.In vrsp (magic_variables p). @@ -2809,16 +2777,6 @@ Section PROOF. lia. Qed. - Lemma pword_uincl ws (w: word ws) (z: pword ws) : - word_uincl w z.(pw_word) → - z = pword_of_word w. - Proof. - case: z => ws' w' ws'_le_ws /= /andP[] ws_le_ws' /eqP ->{w}. - have ? := cmp_le_antisym ws'_le_ws ws_le_ws'. - subst ws'. - by rewrite pword_of_wordE zero_extend_u. - Qed. - Lemma check_to_save_slotP x ofs ofs' ws : check_to_save_slot liparams p (x, ofs) = ok (ofs', ws) -> let: xi := {| v_var := x; v_info := dummy_var_info; |} in @@ -2847,13 +2805,13 @@ Section PROOF. = ok tt → foldM (λ '(x, ofs) m, Let: ws := if vtype x is sword ws then ok ws else Error ErrType in - Let: v := get_var vm x >>= to_word ws in + Let: v := get_var true vm x >>= to_word ws in write m (top + wrepr Uptr ofs)%R v) m1 to_spill = ok m2 → [/\ ∀ ofs ws, ((0 <= ofs)%Z /\ (ofs + wsize_size ws <= lo)%Z) \/ (hi <= ofs /\ wunsigned top + ofs + wsize_size ws <= wbase Uptr)%Z → read m2 (top + wrepr Uptr ofs)%R ws = read m1 (top + wrepr Uptr ofs)%R ws & - ∀ x ofs, (x, ofs) \in to_spill → exists2 ws, is_word_type x.(vtype) = Some ws & exists2 v, get_var vm x >>= to_word ws = ok v & read m2 (top + wrepr Uptr ofs)%R ws = ok v + ∀ x ofs, (x, ofs) \in to_spill → exists2 ws, is_word_type x.(vtype) = Some ws & exists2 v, get_var true vm x >>= to_word ws = ok v & read m2 (top + wrepr Uptr ofs)%R ws = ok v ]. Proof. move => no_overflow. @@ -2889,36 +2847,26 @@ Section PROOF. Sv.Equal (Sv.diff s Sv.empty) s. Proof. SvD.fsetdec. Qed. - Lemma wf_vm_eval_uincl_pundef vm z: - wf_vm vm -> eval_uincl (pundef_addr (vtype z)) (vm.[z])%vmap. - Proof. - move=> /(_ z); case: (vm.[z])%vmap => //. - + by move=> ??; apply eval_uincl_undef. - by case => //; case: vtype. - Qed. - Lemma eval_uincl_kill_vars_incl X1 X2 vm1 vm2 z: - wf_vm vm2 -> Sv.Subset X1 X2 -> - (eval_uincl (kill_vars X1 vm1).[z] vm2.[z] -> - eval_uincl (kill_vars X2 vm1).[z] vm2.[z])%vmap. + value_uincl (kill_vars X1 vm1).[z] vm2.[z] -> + value_uincl (kill_vars X2 vm1).[z] vm2.[z]. Proof. - move=> hwf S; + move=> S; rewrite !kill_varsE; case:Sv_memP => hin1; case: Sv_memP => hin2 // _; first by SvD.fsetdec. - by apply wf_vm_eval_uincl_pundef. + apply/compat_value_uincl_undef/Vm.getP. Qed. Lemma vm_uincl_kill_vars_set_incl X1 X2 vm1 vm2 x v1 v2: - wf_vm vm2 -> Sv.Subset X1 X2 -> - eval_uincl v2 v1 -> - vm_uincl ((kill_vars X1 vm1).[x <- v1])%vmap vm2 -> - vm_uincl ((kill_vars X2 vm1).[x <- v2])%vmap vm2. + value_uincl v2 v1 -> + (kill_vars X1 vm1).[x <- v1] <=1 vm2 -> + (kill_vars X2 vm1).[x <- v2] <=1 vm2. Proof. - move=> hwf S huv huvm z. + move=> S huv huvm z. case: (x =P z) (huvm z) => [<- | /eqP ?]. - + by rewrite !Fv.setP_eq; apply: (eval_uincl_trans huv). - by rewrite !Fv.setP_neq //; apply eval_uincl_kill_vars_incl. + + by rewrite !Vm.setP_eq; apply: value_uincl_trans; apply value_uincl_vm_truncate. + by rewrite !Vm.setP_neq //; apply eval_uincl_kill_vars_incl. Qed. Lemma vm_uincl_after_alloc_stack fd m m' vm0 vm1 vm2 : @@ -2927,14 +2875,13 @@ Section PROOF. let: al := sf_align (f_extra fd) in let: ts' := align_word al (ts - wrepr Uptr sf_sz) in let: vm3 := - (kill_vars (Sv.singleton var_tmp) vm0).[vrsp <- ok (pword_of_word ts)]%vmap + (kill_vars (Sv.singleton var_tmp) vm0).[vrsp <- Vword ts] in - wf_vm vm2 - -> vm_uincl vm3 vm1 + vm3 <=1 vm1 -> sf_return_address (f_extra fd) = RAnone -> let: ssr := savedstackreg (sf_save_stack (f_extra fd)) in - vm2 = vm1 [\ Sv.union ssr (Sv.add var_tmp (Sv.add vrsp vflags)) ] - -> get_var vm2 vrsp = ok (Vword ts') + vm2 =[\ Sv.union ssr (Sv.add var_tmp (Sv.add vrsp vflags)) ] vm1 + -> get_var true vm2 vrsp = ok (Vword ts') -> alloc_stack m al @@ -2942,9 +2889,9 @@ Section PROOF. (sf_stk_ioff (f_extra fd)) (sf_stk_extra_sz (f_extra fd)) = ok m' - -> vm_uincl (set_RSP p m' (kill_vars (ra_undef fd var_tmp) vm0)) vm2. + -> set_RSP p m' (kill_vars (ra_undef fd var_tmp) vm0) <=1 vm2. Proof. - move=> hwfvm2 hvm3 hra hvm2 hgetrsp halloc z. + move=> hvm3 hra hvm2 hgetrsp halloc z. set vm4 := kill_vars _ _. have := hvm3 z. clear hvm3. @@ -2953,18 +2900,14 @@ Section PROOF. - t_vm_get. move: hgetrsp. - rewrite /get_var /=. - case: vm2.[_]%vmap => [|[]] // [???] /=. - move=> /ok_inj /Vword_inj [?]; subst. - move=> /= -> _. - rewrite pword_of_wordE. + rewrite /get_var /= cmp_le_refl; t_xrbindP => _ ->. rewrite (alloc_stack_top_stack halloc) /top_stack_after_alloc. by rewrite wrepr_opp. t_vm_get. rewrite !kill_varsE. case: (Sv_memP _ (ra_undef _ _)). - - move=> _ _. by apply: wf_vm_eval_uincl_pundef. + - move=> _ _. by apply/compat_value_uincl_undef/Vm.getP. rewrite /ra_undef /ra_vm hra {hra} /=. move=> hnin. @@ -2981,7 +2924,7 @@ Section PROOF. Local Lemma Hproc : sem_Ind_proc p var_tmp Pc Pfun. Proof. - red => ii k s1 _ fn fd args m1' s2' res ok_fd free_ra ok_ss rsp_aligned valid_rsp ok_m1' ok_args wt_args exec_body ih ok_res wt_res valid_rsp' -> m1 vm1 _ ra lret sp callee_saved W M X [] fd' ok_fd' <- []. + red => ii k s1 _ fn fd m1' s2' ok_fd free_ra ok_ss rsp_aligned valid_rsp ok_m1' exec_body ih valid_rsp' -> m1 vm1 _ ra lret sp callee_saved M X [] fd' ok_fd' <- []. rewrite ok_fd => _ /Some_inj <- ?; subst ra. rewrite /value_of_ra => ok_lret. case; rewrite ok_fd => _ /Some_inj <- /= ok_sp. @@ -3025,14 +2968,14 @@ Section PROOF. by rewrite stk_sz_0 stk_extra_sz_0 -addE add_0. have X' : - vm_uincl (set_RSP p m1' (kill_vars (ra_undef fd var_tmp) s1)) vm1. + set_RSP p m1' (kill_vars (ra_undef fd var_tmp) s1) <=1 vm1. + apply: vm_uincl_kill_vars_set_incl X => //. + by rewrite /ra_undef /ra_vm EQ /=; clear; SvD.fsetdec. by rewrite top_stack_preserved. - have {E} [m2 vm2] := E m1 vm1 [::] [::] W M' X' (λ _ _, erefl) ok_body. - rewrite /= => E K2 W2 X2 H2 M2. - eexists m2 _; [ exact: E | | exact: W2 | | | exact: mm_free M2 ]; cycle 2. + have {E} [m2 vm2] := E m1 vm1 [::] [::] M' X' (λ _ _, erefl) ok_body. + rewrite /= => E K2 X2 H2 M2. + eexists m2 _; [ exact: E | | | | exact: mm_free M2 ]; cycle 2. + move => a a_range /negbTE nv. have A := alloc_stackP ok_m1'. have [L] := ass_above_limit A. @@ -3045,13 +2988,13 @@ Section PROOF. have := ass_ioff A. move: (sf_stk_sz _) (sf_stk_extra_sz _) (sf_stk_ioff _) stk_sz_0 stk_extra_sz_0 H. lia. - + apply: vmap_eq_exceptI; last exact: K2. + + apply: eq_exI; last exact: K2. rewrite to_save_nil Sv_diff_empty. exact: Sv_Subset_union_left. have S : stack_stable m1' s2'. + exact: sem_one_varmap_facts.sem_stack_stable exec_body. - move => x; move: (X2 x); rewrite /set_RSP !Fv.setP; case: eqP => // ?; subst. - by rewrite valid_rsp' -(ss_top_stack S) top_stack_preserved. + move => x; move: (X2 x); rewrite /set_RSP !Vm.setP; case: eqP => // ?; subst. + by rewrite valid_rsp' -(ss_top_stack S) top_stack_preserved vm_truncate_val_eq. } + (* RSP is saved into register “saved_rsp” *) { have {ih} := ih fn xH. @@ -3080,10 +3023,10 @@ Section PROOF. move => ok_fd' E. have ok_body : is_linear_of fn (P ++ lbody ++ Q). + by rewrite /is_linear_of ok_fd' /=; eauto. - have ok_rsp : get_var vm1 vrsp = ok (Vword (top_stack (emem s1))). - + move: (X vrsp). rewrite Fv.setP_eq /get_var /=. - by case: _.[_]%vmap => //= - [] sz w ? /pword_of_word_uincl[] /= ? -> {w}; subst. - have [vm [hsem hwf_vm hvm hgetrsp hgetr hflags]] := + have ok_rsp : get_var true vm1 vrsp = ok (Vword (top_stack (emem s1))). + + move: (X vrsp). rewrite Vm.setP_eq vm_truncate_val_eq // /get_var. + by move=> /get_word_uincl_eq -/(_ (subtype_refl _)) ->. + have [vm [hsem hvm hgetrsp hgetr hflags]] := spec_lip_set_up_sp_register hliparams (P := [::]) @@ -3094,12 +3037,11 @@ Section PROOF. hneq_vtmp_vrsp hnot_saved_stack saved_stack_not_RSP - ok_rsp - W. + ok_rsp. have X' : - vm_uincl (set_RSP p m1' (kill_vars (ra_undef fd var_tmp) s1)) vm. - + apply: (vm_uincl_after_alloc_stack hwf_vm X EQ _ hgetrsp ok_m1'). + set_RSP p m1' (kill_vars (ra_undef fd var_tmp) s1) <=1 vm. + + apply: (vm_uincl_after_alloc_stack X EQ _ hgetrsp ok_m1'). rewrite /= E1 /=. rewrite -SvP.MP.add_union_singleton. exact: hvm. @@ -3109,10 +3051,10 @@ Section PROOF. rewrite /P /=. by rewrite set_up_sp_register_has_label. - move: E => /(_ m1 vm P Q hwf_vm (mm_alloc M ok_m1') X' D ok_body). + move: E => /(_ m1 vm P Q (mm_alloc M ok_m1') X' D ok_body). case => m2 vm2. rewrite /= !size_cat /= addn1. - move => E K2 W2 X2 H2 M2. + move => E K2 X2 H2 M2. eexists. - apply: (lsem_trans hsem). @@ -3131,16 +3073,16 @@ Section PROOF. set ts := @top_stack _ mem _ _ s1. have hgetrg : - get_gvar [::] s (mk_lvar ri) = ok (Vword ts). + get_gvar true [::] s (mk_lvar ri) = ok (Vword ts). + rewrite /get_gvar /= /get_var /=. rewrite -(K2 _ saved_stack_not_written) /=. - rewrite -/(get_var vm ri). + rewrite -/(get_var true vm ri). by rewrite hgetr. have hwrite : - write_var vrspi (Vword ts) s - = ok (with_vm s vm2.[vrspi <- ok (pword_of_word ts)]%vmap). - - by rewrite -to_pword_u. + write_var true vrspi (Vword ts) s + = ok (with_vm s vm2.[vrspi <- Vword ts]). + - by rewrite write_var_eq_type. rewrite (spec_lmove hliparams _ _ _ _ hrestore_rsp hgetrg hwrite) /=. clear hrestore_rsp hgetrg hwrite. @@ -3151,23 +3093,18 @@ Section PROOF. + rewrite to_save_empty Sv_diff_empty. clear - ok_rsp K2 hvm. move => x. - rewrite !Sv.union_spec !Sv.add_spec Sv.singleton_spec Fv.setP => + rewrite !Sv.union_spec !Sv.add_spec Sv.singleton_spec Vm.setP => /Decidable.not_or[] x_not_k /Decidable.not_or[] /Decidable.not_or[] x_not_tmp x_not_flags x_not_saved_stack. case: eqP => x_rsp. - * subst; move: ok_rsp; rewrite /get_var. - case: _.[_]%vmap; last by case. - move => [] /= sz w hle /ok_inj /Vword_inj[] ?; subst => /= ->. - by rewrite pword_of_wordE. + * by subst; move/get_varP: ok_rsp => [<-]; rewrite vm_truncate_val_eq. rewrite -K2; last exact: x_not_k. rewrite hvm; first done. repeat (move=> /Sv.add_spec [] //). by apply: nesym. - + exact: wf_vm_set. - + move => x; rewrite Fv.setP; case: eqP => ?. - * by subst; rewrite Fv.setP_eq. - rewrite Fv.setP_neq; last by apply/eqP. - rewrite /set_RSP Fv.setP_neq; last by apply/eqP. - done. + + move => x; rewrite Vm.setP; case: eqP => ?. + * by subst; rewrite Vm.setP_eq. + rewrite Vm.setP_neq; last by apply/eqP. + by rewrite /set_RSP Vm.setP_neq //; apply/eqP. + move => a [] a_lo a_hi /negbTE nv. have A := alloc_stackP ok_m1'. have [L H] := ass_above_limit A. @@ -3213,9 +3150,9 @@ Section PROOF. is_linear_of fn (cmd_set_up_sp ++ cmd_push_to_save ++ lbody ++ Q). + by rewrite catA /is_linear_of ok_fd' /=; eauto. - have ok_rsp : get_var vm1 vrsp = ok (Vword (top_stack (emem s1))). - + move: (X vrsp). rewrite Fv.setP_eq /get_var /=. - by case: _.[_]%vmap => //= - [] sz w ? /pword_of_word_uincl[] /= ? -> {w}; subst. + have ok_rsp : get_var true vm1 vrsp = ok (Vword (top_stack (emem s1))). + + move: (X vrsp); rewrite Vm.setP_eq /get_var /= cmp_le_refl. + by move => /get_word_uincl_eq -/(_ (subtype_refl _)) ->. have A := alloc_stackP ok_m1'. have can_spill := mm_can_write_after_alloc _ ok_m1' stk_sz_pos stk_extra_pos. @@ -3252,7 +3189,7 @@ Section PROOF. rewrite -/ts. move=> ok_m2. - have [vm2 [hsem hwf_vm2 hvm2 hgetrsp hflags]] := + have [vm2 [hsem hvm2 hgetrsp hflags]] := spec_lip_set_up_sp_stack (s := {| escs:= escs s1; evm := vm1; emem := m1; |}) (P := [::]) @@ -3261,12 +3198,11 @@ Section PROOF. hset_up_sp hneq_vtmp_vrsp ok_rsp - W ok_m2. have X' : - vm_uincl (set_RSP p m1' (kill_vars (ra_undef fd var_tmp) s1)) vm2. - + apply: (vm_uincl_after_alloc_stack hwf_vm2 X EQ _ hgetrsp ok_m1'). + set_RSP p m1' (kill_vars (ra_undef fd var_tmp) s1) <=1 vm2. + + apply: (vm_uincl_after_alloc_stack X EQ _ hgetrsp ok_m1'). rewrite /savedstackreg E1. rewrite Sv_union_empty. exact: hvm2. @@ -3280,24 +3216,18 @@ Section PROOF. have is_ok_vm1_vm2 : forall x, Sv.mem x (sv_of_list fst (sf_to_save (f_extra fd))) - -> is_ok (get_var vm1 x >>= of_val (vtype x)) - -> is_ok (get_var vm2 x >>= of_val (vtype x)). + -> is_ok (get_var true vm1 x >>= of_val (vtype x)) + -> is_ok (get_var true vm2 x >>= of_val (vtype x)). + move=> x hx ok_x. case: (SvP.MP.In_dec x (Sv.add var_tmp (Sv.add vrsp vflags))) => hin. - { - move: hin => /Sv.add_spec [? | hin]. + + move: hin => /Sv.add_spec [? | hin]. - subst x. by move: tmp_not_saved => /negP. move: hin => /Sv.add_spec [? | hin]. - subst x. rewrite hgetrsp /=. by rewrite truncate_word_u. - rewrite /get_var. - have := hflags _ hin. - case: vm2.[x]%vmap. - - have := vflagsP hin. by case: (x) => /= _ ? ->. - by move=> _ <- //. - } - - rewrite /get_var. - by rewrite (hvm2 _ hin). + rewrite /get_var; have := hflags _ hin. + have := Vm.getP vm2 x; rewrite (vflagsP hin) => /compat_valEl [ -> /= h | [b ->]//]. + by move: ok_x; rewrite /get_var h. + by rewrite /get_var (hvm2 _ hin). have : ∃ m3, @@ -3321,7 +3251,7 @@ Section PROOF. in [/\ foldM (λ '(x, ofs) m, Let: ws := if vtype x is sword ws then ok ws else Error ErrType in - Let: v := get_var vm2 x >>= to_word ws in + Let: v := get_var true vm2 x >>= to_word ws in write m (top + wrepr Uptr ofs)%R v) m2 (sf_to_save (f_extra fd)) = ok m3, preserved_metadata s1 m2 m3, match_mem s1 m3 & @@ -3355,7 +3285,7 @@ Section PROOF. move: ih => /(_ _ wf_to_save ok_to_save) ih. have : - is_ok (Let x := get_var vm2 x in to_word ws x). + is_ok (Let x := get_var true vm2 x in to_word ws x). - apply: (is_ok_vm1_vm2 _ _ wf_x). exact: sv_of_list_mem_head. case get_x: get_var => [ v | // ]. @@ -3419,11 +3349,11 @@ Section PROOF. case => m3 [] ok_m3 H3 M3' exec_save_to_stack. have M3 : match_mem m1' m3 := mm_alloc M3' ok_m1'. rewrite catA in ok_body. - move: E => /(_ m3 vm2 P Q hwf_vm2 M3 X' D ok_body). - case => m4 vm4 E K4 W4 X4 H4 M4. - have vm4_get_rsp : get_var vm4 vrsp >>= to_pointer = ok top. + move: E => /(_ m3 vm2 P Q M3 X' D ok_body). + case => m4 vm4 E K4 X4 H4 M4. + have vm4_get_rsp : get_var true vm4 vrsp >>= to_pointer = ok top. + rewrite /get_var /= -K4. - * rewrite -/(get_var vm2 vrsp) hgetrsp /=. + * rewrite -/(get_var true vm2 vrsp) hgetrsp /=. + by rewrite truncate_word_u -wrepr_opp. have /disjointP K := sem_RSP_GD_not_written var_tmp_not_magic exec_body. move => /K; apply; exact: RSP_in_magic. @@ -3476,13 +3406,12 @@ Section PROOF. lvm := vm5; lfn := fn; lpc := size (P ++ lbody ++ tail) - |}, - wf_vm vm5 + |} & forall x, vm5.[x] = if x \in (map fst (sf_to_save (f_extra fd))) then vm2.[x] else vm4.[x] - ]%vmap. + ]. { clear E K4 X4. move: ok_body ok_to_save wf_to_save read_spilled. @@ -3491,8 +3420,8 @@ Section PROOF. move: (P ++ lbody). have : (sf_stk_sz (f_extra fd) <= sf_stk_sz (f_extra fd))%Z by lia. move: is_ok_vm1_vm2. - elim: (sf_to_save _) {-1} (sf_stk_sz (f_extra fd))%Z vm4 W4 vm4_get_rsp - => [ | [ x ofs ] to_save ih ] lo vm4 W4 vm4_get_rsp is_ok_vm1_vm2 sz'_le_lo prefix ok_body /all_disjoint_aligned_betweenP ok_to_save wf_to_save read_spilled. + elim: (sf_to_save _) {-1} (sf_stk_sz (f_extra fd))%Z vm4 vm4_get_rsp + => [ | [ x ofs ] to_save ih ] lo vm4 vm4_get_rsp is_ok_vm1_vm2 sz'_le_lo prefix ok_body /all_disjoint_aligned_betweenP ok_to_save wf_to_save read_spilled. * exists vm4; split => //. rewrite cats0; exact: rt_refl. case: ok_to_save => x_ofs [] ws []. @@ -3502,25 +3431,23 @@ Section PROOF. move: wf_to_save; rewrite /vm_initialized_on /=. case/andP => /is_ok_vm1_vm2. move=> get_x wf_to_save. - have : is_ok (Let x := get_var vm2 x in of_val (sword ws) x). + have : is_ok (Let x := get_var true vm2 x in of_val (sword ws) x). - apply: get_x. exact: sv_of_list_mem_head. case ok_x: get_var => [ v | // ] /=. case ok_v: to_word => [ w | // ] _. - set vm5 := vm4.[x <- ok (pword_of_word w)]%vmap. - have W5: wf_vm vm5. - * exact: wf_vm_set W4. - have vm5_get_rsp : get_var vm5 vrsp >>= to_pointer = ok top. + set vm5 := vm4.[x <- Vword w]. + have vm5_get_rsp : get_var true vm5 vrsp >>= to_pointer = ok top. * case: (vrsp =P x) => x_rsp; - last by rewrite /get_var Fv.setP_neq ?vm4_get_rsp //; apply/eqP => ?; exact: x_rsp. + last by rewrite /get_var Vm.setP_neq ?vm4_get_rsp //; apply/eqP => ?; exact: x_rsp. have ? : ws = Uptr by case: x_rsp. subst. - rewrite x_rsp /get_var Fv.setP_eq /= truncate_word_u. + rewrite x_rsp get_var_eq //= cmp_le_refl /= truncate_word_u. move: ok_x ok_v. rewrite -/x -x_rsp hgetrsp. move=> /ok_inj <- /=. by rewrite truncate_word_u -wrepr_opp. - move: ih => /(_ _ _ W5 vm5_get_rsp) ih. + move: ih => /(_ _ _ vm5_get_rsp) ih. move: (ok_body). rewrite -cat_rcons => /ih {} ih. have : (sf_stk_sz (f_extra fd) <= ofs + wsize_size ws)%Z. @@ -3538,7 +3465,7 @@ Section PROOF. * move => x' ofs' saved'; apply: read_spilled. by rewrite inE saved' orbT. - move => vm6 [] E W6 X6. + move => vm6 [] E X6. exists vm6; split. * apply: lsem_step; last exact: E. rewrite /lsem1 /step. @@ -3556,7 +3483,7 @@ Section PROOF. + rewrite /= vm4_get_rsp truncate_word_u /=. have : read m4 (top + wrepr Uptr ofs)%R ws - = get_var vm2 x >>= to_word ws. + = get_var true vm2 x >>= to_word ws. * rewrite -(@eq_read _ _ _ _ m3); last first. - move=> i i_range. have ofs_lo : (sf_stk_sz (f_extra fd) <= ofs)%Z. @@ -3586,24 +3513,22 @@ Section PROOF. move => ->. by rewrite ok_x /= ok_v. + by rewrite truncate_word_u. - by rewrite /= /write_var /= sumbool_of_boolET. - * exact: W6. + done. move => z; move: (X6 z). rewrite inE. case: ifP => z_to_save ->; first by rewrite orbT. - case: eqP => /= z_x; last by rewrite Fv.setP_neq //; apply/eqP => ?; exact: z_x. - rewrite z_x Fv.setP_eq. - move: ok_v. - apply: on_vuP ok_x => // /= w' -> <- /to_word_to_pword <-. - clear. - by case: w' => /= ws' w le; rewrite sumbool_of_boolET. + case: eqP => /= z_x; last by rewrite Vm.setP_neq //; apply/eqP => ?; exact: z_x. + rewrite z_x Vm.setP_eq vm_truncate_val_eq //. + have := @get_word_uincl_eq _ vm2 x _ w; move: ok_v. + move/get_varP: ok_x => [<- _ _] /to_wordI' [sz [w' [hle -> ->]]] /= -> //. + by apply word_uincl_zero_ext. } - case => vm5 [] exec_restore_from_stack wf_vm5 ok_vm5. - have vm5_get_rsp : get_var vm5 {| vtype := sword Uptr; vname := sp_rsp (p_extra p) |} >>= to_pointer = ok top. + case => vm5 [] exec_restore_from_stack ok_vm5. + have vm5_get_rsp : get_var true vm5 {| vtype := sword Uptr; vname := sp_rsp (p_extra p) |} >>= to_pointer = ok top. + rewrite /get_var /= ok_vm5. case: ifP => _; last rewrite -K4. - 1-2: rewrite -/(get_var vm2 vrsp) hgetrsp. + 1-2: rewrite -/(get_var true vm2 vrsp) hgetrsp. 1-2: by rewrite -wrepr_opp /= truncate_word_u. have /disjointP K := sem_RSP_GD_not_written var_tmp_not_magic exec_body. @@ -3634,12 +3559,11 @@ Section PROOF. * rewrite /= vm5_get_rsp /= truncate_word_u /=. by rewrite read_saved_rsp /=. * by rewrite truncate_word_u. - by rewrite /= /write_var /= sumbool_of_boolET. - + done. + move => x /Sv_memP H. - rewrite Fv.setP; case: eqP => x_rsp. - * move: (X x); subst; rewrite Fv.setP_eq. - by case: _.[_]%vmap => //= ? /pword_uincl ->. + rewrite Vm.setP; case: eqP => x_rsp. + * move: (X x); subst; rewrite Vm.setP_eq vm_truncate_val_eq //. + by move=> /get_word_uincl_eq; apply. move: H. rewrite SvP.diff_mem negb_and => /orP[]; last first. * move/negbNE/Sv_memP/sv_of_listP; rewrite map_id /= => hx. @@ -3663,7 +3587,7 @@ Section PROOF. rewrite !SvP.union_mem Sv_mem_add SvP.empty_mem !orbA !orbF -!orbA. case/norP => x_ni_k /norP[] x_neq_tmp x_not_flag. - transitivity vm2.[x]%vmap. + transitivity vm2.[x]. + rewrite hvm2; first done. move=> /Sv.add_spec [?|]. * subst x. by move: x_neq_tmp => /eqP. @@ -3671,14 +3595,13 @@ Section PROOF. * by subst x. by apply/Sv_memP. - transitivity vm4.[x]%vmap; first by rewrite K4 //; apply/Sv_memP. + transitivity vm4.[x]; first by rewrite K4 //; apply/Sv_memP. rewrite ok_vm5; case: ifP => // _. rewrite K4 //. exact/Sv_memP. - + exact: wf_vm_set wf_vm5. - + move => x; rewrite !Fv.setP; case: eqP => x_rsp; first by subst. + + move => x; rewrite !Vm.setP; case: eqP => x_rsp; first by subst. move => /sv_of_listP; rewrite map_id => /negbTE x_not_to_save. - apply: (eval_uincl_trans (X4 x)). + apply: (value_uincl_trans (X4 x)). by rewrite ok_vm5 x_not_to_save. + etransitivity; first exact: H2. etransitivity; first exact: H3. @@ -3701,15 +3624,15 @@ Section PROOF. move => ok_fd'. have ok_body : is_linear_of fn ([:: P ] ++ lbody ++ Q). + by rewrite /is_linear_of ok_fd'; eauto. - have X1 : vm_uincl (set_RSP p m1' (kill_vars (ra_undef fd var_tmp) s1)) vm1. + have X1 : set_RSP p m1' (kill_vars (ra_undef fd var_tmp) s1) <=1 vm1. + apply: vm_uincl_kill_vars_set_incl X => //. + by rewrite /ra_undef /ra_vm EQ; SvD.fsetdec. rewrite (alloc_stack_top_stack ok_m1') top_stack_after_aligned_alloc; last by exact: sp_aligned. by rewrite wrepr_opp -/(stack_frame_allocation_size fd.(f_extra)). have D : disjoint_labels 2 lbl [:: P]. + by move => q [A B]; rewrite /P /is_label /= orbF; apply/eqP => ?; subst; lia. - have {E} [ m2 vm2 E K2 W2 ok_vm2 H2 M2 ] := E m1 vm1 [:: P] Q W (mm_alloc M ok_m1') X1 D ok_body. - eexists; [ | | exact: W2 | | | exact: mm_free M2 ]; cycle 3. + have {E} [ m2 vm2 E K2 ok_vm2 H2 M2 ] := E m1 vm1 [:: P] Q (mm_alloc M ok_m1') X1 D ok_body. + eexists; [ | | | | exact: mm_free M2 ]; cycle 3. + move => a [] a_lo a_hi /negbTE nv. have A := alloc_stackP ok_m1'. have [L H] := ass_above_limit A. @@ -3728,7 +3651,7 @@ Section PROOF. apply: LSem_step. rewrite catA in ok_body. rewrite /lsem1 /step -(addn0 (size ([:: P] ++ lbody))) (find_instr_skip ok_body) /= /eval_instr /= /get_gvar /= /get_var /=. - have ra_not_written : (vm2.[ Var spointer ra ] = vm1.[ Var spointer ra ])%vmap. + have ra_not_written : vm2.[ Var spointer ra ] = vm1.[ Var spointer ra ]. * symmetry; apply: K2. have /andP [_ ?] := ra_notin_k. by apply/Sv_memP. @@ -3736,16 +3659,16 @@ Section PROOF. have := decode_encode_label small_dom_p' mem_lret. rewrite ok_retptr /= => -> /=. case: ok_cbody => fd' -> -> /=; rewrite ok_pc /setcpc /=; reflexivity. - + apply: vmap_eq_exceptI K2. + + apply: eq_exI K2. exact: SvP.MP.union_subset_1. - move => ?; rewrite /set_RSP !Fv.setP; case: eqP => // ?; subst. + move => ?; rewrite /set_RSP !Vm.setP; case: eqP => // ?; subst. move: (ok_vm2 vrsp). have S : stack_stable m1' s2'. + exact: sem_one_varmap_facts.sem_stack_stable exec_body. rewrite valid_rsp' -(ss_top_stack S) (alloc_stack_top_stack ok_m1'). rewrite top_stack_after_aligned_alloc; last by exact: sp_aligned. - by rewrite wrepr_opp. + by rewrite vm_truncate_val_eq // wrepr_opp. } (* Internal function, return address in stack at offset “rastack” *) { @@ -3765,10 +3688,9 @@ Section PROOF. move => ok_fd'. have ok_body : is_linear_of fn ([:: P1; P2 ] ++ lbody ++ Q). + by rewrite /is_linear_of ok_fd'; eauto. - have := X vrsp; rewrite Fv.setP_eq /=. - case ok_rsp: (vm1.[_])%vmap => [ [ws rsp hle] | //] /= /andP /= [] h /eqP. - have ? := cmp_le_antisym hle h; subst ws. - rewrite pword_of_wordE in ok_rsp; rewrite zero_extend_u => eq_rsp {h hle}. + have := X vrsp; rewrite Vm.setP_eq /= cmp_le_refl. + move=> /get_word_uincl_eq -/(_ (subtype_refl _)). + set rsp := (X in Vword X) => ok_rsp. case/and4P: ok_ret_addr => /andP [] _ is_store /eqP ? /eqP hioff sf_align_for_ptr; subst rastack. have spec_m1' := alloc_stackP ok_m1'. have is_align_m1' := ass_align_stk spec_m1'. @@ -3799,34 +3721,28 @@ Section PROOF. have {X} TmS := wunsigned_sub_small S_range X. rewrite TmS in above_limit. lia. - have X1 : vm_uincl (set_RSP p m1' (kill_vars (ra_undef fd var_tmp) s1)) vm1. + have X1 : set_RSP p m1' (kill_vars (ra_undef fd var_tmp) s1) <=1 vm1. + apply: vm_uincl_kill_vars_set_incl X => //. + by rewrite /ra_undef /ra_vm EQ; SvD.fsetdec. - by rewrite eq_rsp ts_rsp. + by rewrite ts_rsp. have D : disjoint_labels 2 lbl [:: P1; P2]. + move => q [A B]; rewrite /P1 /P2 /= is_label_lstore /is_label /= orbF; apply/eqP; lia. - have {E} [ m2 vm2 E K2 W2 ok_vm2 H2 M2 ] := E m1s vm1 [:: P1; P2] Q W (mm_alloc M' ok_m1') X1 D ok_body. - exists m2 (vm2.[vrsp <- ok - {| - pw_size := Uptr; - pw_word := rsp + wrepr Uptr (wsize_size Uptr); - pw_proof := (cmp_le_refl Uptr) - |}])%vmap; last exact: mm_free M2. + have {E} [ m2 vm2 E K2 ok_vm2 H2 M2 ] := E m1s vm1 [:: P1; P2] Q (mm_alloc M' ok_m1') X1 D ok_body. + exists m2 (vm2.[vrsp <- Vword (rsp + wrepr Uptr (wsize_size Uptr))]); last exact: mm_free M2. + apply: lsem_step. + rewrite /lsem1 /step /= /find_instr /= ok_fd' /=. apply: (spec_lassign hliparams p' (s1 := {|escs:= escs s1; emem := m1; evm := vm1|}) _ _ _ is_store). - + by rewrite /= /get_gvar /= get_varE ok_ra1 zero_extend_u /=. + + by rewrite /= /get_gvar /get_var /= ok_ra1 zero_extend_u /=. + by rewrite truncate_word_u. - by rewrite /write_lexpr get_varE /= ok_rsp /= !truncate_word_u /= wrepr0 GRing.addr0 ok_m1s. + by rewrite /write_lexpr /= /get_var ok_rsp /= !truncate_word_u /= wrepr0 GRing.addr0 ok_m1s. apply: lsem_trans; first exact: E. apply: LSem_step. rewrite catA in ok_body. rewrite /lsem1 /step -(addn0 (size ([:: P1; P2] ++ lbody))) (find_instr_skip ok_body) /= /eval_instr /= /get_gvar /= /get_var /=. move: (ok_vm2 vrsp). rewrite -(sem_preserved_RSP_GD var_tmp_not_magic exec_body); last exact: RSP_in_magic. - rewrite /= /set_RSP Fv.setP_eq /= lp_rspE -/vrsp. - case: vm2.[_]%vmap => // - [] ?? pw_proof /pword_of_word_uincl /= [] ??; subst. - rewrite (sumbool_of_boolET pw_proof) truncate_word_u /=. + rewrite /= /set_RSP Vm.setP_eq /= lp_rspE -/vrsp cmp_le_refl. + move=> /get_word_uincl_eq -/(_ (subtype_refl _)) -> /=; rewrite truncate_word_u /=. case/and3P: ok_stk_sz; rewrite !zify => stk_sz_pos stk_extra_pos sf_noovf. assert (root_range := wunsigned_range (stack_root m1')). have A := alloc_stackP ok_m1'. @@ -3862,17 +3778,14 @@ Section PROOF. rewrite ts_rsp (writeP_eq ok_m1s) /=. have := decode_encode_label small_dom_p' mem_lret. rewrite ok_retptr /= => -> /=. - case: ok_cbody => fd' -> -> /=; rewrite ok_pc /setcpc /=. - rewrite (Eqdep_dec.UIP_dec Bool.bool_dec pw_proof (cmp_le_refl Uptr)). - reflexivity. - + apply vmap_eq_exceptT with vm2. - + by apply: vmap_eq_exceptI K2; SvD.fsetdec. - by move=> ? hx; rewrite Fv.setP_neq //; apply/eqP; SvD.fsetdec. - + by apply wf_vm_set. - + by move => ?; rewrite /set_RSP !Fv.setP; case: eqP => // ?; subst. + by case: ok_cbody => fd' -> -> /=; rewrite ok_pc. + + apply eq_exT with vm2. + + by apply: eq_exI K2; SvD.fsetdec. + by move=> ? hx; rewrite Vm.setP_neq //; apply/eqP; SvD.fsetdec. + + by move => ?; rewrite /set_RSP !Vm.setP; case: eqP => // ?; subst. etransitivity. + apply: (preserved_meta_store_top_stack ok_m1') => //. - by rewrite top_stack_after_aligned_alloc // wrepr_opp eq_rsp; apply: ok_m1s. + by rewrite top_stack_after_aligned_alloc // wrepr_opp; apply: ok_m1s. move => a [] a_lo a_hi /negbTE nv. have A := alloc_stackP ok_m1'. have [L R] := ass_above_limit A. @@ -3889,7 +3802,7 @@ Section PROOF. (* Directly path on top of the stack *) case: lret ok_lret => // - [] [] [] caller lret cbody pc [] ok_cbody ok_pc mem_lret [] retptr ok_retptr [] rsp ok_rsp ok_ra. have := X vrsp. - rewrite Fv.setP_eq ok_rsp => /andP[] _ /eqP /=. + rewrite Vm.setP_eq vm_truncate_val_eq // ok_rsp => /andP[] _ /eqP /=. rewrite zero_extend_u => ?; subst rsp. have {ih} := ih fn 2%positive. rewrite /checked_c ok_fd chk_body => /(_ erefl). @@ -3900,29 +3813,24 @@ Section PROOF. move => ok_fd'. have ok_body : is_linear_of fn ([:: P ] ++ lbody ++ Q). + by rewrite /is_linear_of ok_fd'; eauto. - have X1 : vm_uincl (set_RSP p m1' (kill_vars (ra_undef fd var_tmp) s1)) vm1. + have X1 : set_RSP p m1' (kill_vars (ra_undef fd var_tmp) s1) <=1 vm1. + apply: vm_uincl_kill_vars_set_incl X => //. + by SvD.fsetdec. rewrite (alloc_stack_top_stack ok_m1') top_stack_after_aligned_alloc; last by exact: sp_aligned. by rewrite wrepr_opp -/(stack_frame_allocation_size fd.(f_extra)). have D : disjoint_labels 2 lbl [:: P]. + by move => q [A B]; rewrite /P /is_label /= orbF; apply/eqP => ?; subst; lia. - have {E} [ m2 vm2 E K2 W2 ok_vm2 H2 M2 ] := E m1 vm1 [:: P] Q W (mm_alloc M ok_m1') X1 D ok_body. - exists m2 (vm2.[vrsp <- ok - {| - pw_size := Uptr; - pw_word := top_stack (emem s1) - wrepr Uptr (round_ws (sf_align (f_extra fd)) (sf_stk_sz (f_extra fd) + sf_stk_extra_sz (f_extra fd))) + wrepr Uptr (wsize_size Uptr); - pw_proof := (cmp_le_refl Uptr) - |}])%vmap; last exact: mm_free M2. + have {E} [ m2 vm2 E K2 ok_vm2 H2 M2 ] := E m1 vm1 [:: P] Q (mm_alloc M ok_m1') X1 D ok_body. + exists m2 (vm2.[vrsp <- Vword + (top_stack (emem s1) - wrepr Uptr (round_ws (sf_align (f_extra fd)) (sf_stk_sz (f_extra fd) + sf_stk_extra_sz (f_extra fd))) + wrepr Uptr (wsize_size Uptr))]); last exact: mm_free M2. + apply: lsem_trans; first exact: E. apply: LSem_step. rewrite catA in ok_body. rewrite /lsem1 /step -(addn0 (size ([:: P] ++ lbody))) (find_instr_skip ok_body) /= /eval_instr /= /get_gvar /= /get_var /=. move: (ok_vm2 vrsp). rewrite -(sem_preserved_RSP_GD var_tmp_not_magic exec_body); last exact: RSP_in_magic. - rewrite /= /set_RSP Fv.setP_eq /= lp_rspE -/vrsp. - case: vm2.[_]%vmap => // - [] ?? pw_proof /pword_of_word_uincl /= [] ??; subst. - rewrite (sumbool_of_boolET pw_proof) truncate_word_u /=. + rewrite /= /set_RSP Vm.setP_eq /= lp_rspE -/vrsp cmp_le_refl. + move=> /get_word_uincl_eq -/(_ (subtype_refl _)) -> /=; rewrite truncate_word_u /=. case/and3P: ok_ret_addr => /eqP hrastack /eqP hioff sf_aligned_for_ptr. case/and3P: ok_stk_sz; rewrite !zify => stk_sz_pos stk_extra_pos sf_noovf. assert (root_range := wunsigned_range (stack_root m1')). @@ -3961,14 +3869,11 @@ Section PROOF. move: ok_ra; rewrite wrepr0 GRing.addr0 /stack_frame_allocation_size wrepr_opp => -> /=. have := decode_encode_label small_dom_p' mem_lret. rewrite ok_retptr /= => -> /=. - case: ok_cbody => fd' -> -> /=; rewrite ok_pc /setcpc /=. - rewrite (Eqdep_dec.UIP_dec Bool.bool_dec pw_proof (cmp_le_refl Uptr)). - reflexivity. - + apply vmap_eq_exceptT with vm2. - + by apply: vmap_eq_exceptI K2; SvD.fsetdec. - by move=> x hx; rewrite Fv.setP_neq //; apply/eqP; SvD.fsetdec. - + by apply wf_vm_set. - + by move => ?; rewrite /set_RSP !Fv.setP; case: eqP => // ?; subst. + by case: ok_cbody => fd' -> -> /=; rewrite ok_pc. + + apply eq_exT with vm2. + + by apply: eq_exI K2; SvD.fsetdec. + by move=> x hx; rewrite Vm.setP_neq //; apply/eqP; SvD.fsetdec. + + by move => ?; rewrite /set_RSP !Vm.setP; case: eqP => // ?; subst. move => a [] a_lo a_hi /negbTE nv. have A := alloc_stackP ok_m1'. have [L H] := ass_above_limit A. @@ -4009,25 +3914,21 @@ Section PROOF. sem_export_call p var_tmp gd scs m fn args scs' m' res → ∃ fd, [/\ - get_fundef p'.(lp_funcs) fn = Some fd, + get_fundef p'.(lp_funcs) fn = Some fd, fd.(lfd_export) & ∀ lm vm args', - wf_vm vm → - vm.[vid (lp_rsp p')]%vmap = ok (pword_of_word (top_stack m)) → + vm.[vid (lp_rsp p')] = Vword (top_stack m) → match_mem m lm → - mapM (λ x : var_i, get_var vm x) fd.(lfd_arg) = ok args' → + mapM (λ x : var_i, get_var false vm x) fd.(lfd_arg) = ok args' → List.Forall2 value_uincl args args' → - vm.[vid p'.(lp_rip)]%vmap = ok (pword_of_word gd) → + vm.[vid p'.(lp_rip)] = Vword gd → vm_initialized_on vm ((var_tmp : var) :: lfd_callee_saved fd) → - all2 check_ty_val fd.(lfd_tyin) args' ∧ ∃ vm' lm' res', - (* TODO: vm = vm' [\ k ] ; stack_stable m m' ; etc. *) [/\ lsem_exportcall p' scs lm fn vm scs' lm' vm', match_mem m' lm', - mapM (λ x : var_i, get_var vm' x) fd.(lfd_res) = ok res', - List.Forall2 value_uincl res res' & - all2 check_ty_val fd.(lfd_tyout) res' + mapM (λ x : var_i, get_var false vm' x) fd.(lfd_res) = ok res' & + List.Forall2 value_uincl res res' ] ]. Proof. @@ -4035,11 +3936,10 @@ Section PROOF. exists (linear_fd fn fd).2; split. - exact: get_fundef_p' ok_fd. - exact: Export. - rewrite lp_rspE => lm vm args' ok_vm vm_rsp M ok_args' args_args' vm_rip safe_registers. - have {H}[] := H vm args' ok_vm ok_args' args_args' vm_rsp. + rewrite lp_rspE => lm vm args' vm_rsp M ok_args' args_args' vm_rip safe_registers. + have {H}[] := H vm args' ok_args' args_args' vm_rsp. - by move: vm_rip; rewrite lp_ripE. - move => m1 k m2 vm2 res' ok_save_stack ok_callee_saved ok_m1 wt_args' sexec ok_res' res_res' wt_res' vm2_rsp ?; subst m'. - split; first by []. + move => m1 k m2 vm2 res' ok_save_stack ok_callee_saved ok_m1 sexec ok_res' res_res' vm2_rsp ?; subst m'. set k' := Sv.union k (Sv.union match fd.(f_extra).(sf_return_address) with RAreg ra | RAstack (Some ra) _ => Sv.singleton ra | RAstack _ _ => Sv.empty | RAnone => Sv.add var_tmp vflags end (if fd.(f_extra).(sf_save_stack) is SavedStackReg r then Sv.singleton r else Sv.empty)). set s1 := {| escs := scs; emem := m ; evm := vm |}. set s2 := {| escs := scs'; emem := free_stack m2 ; evm := set_RSP p (free_stack m2) vm2 |}. @@ -4051,24 +3951,20 @@ Section PROOF. + by rewrite /top_stack_aligned; move/eqP: Export => ->. + exact: vm_rsp. + exact: ok_m1. - + exact: ok_args'. - + exact: wt_args'. + move: sexec. rewrite /ra_undef_vm /ra_undef /ra_undef_vm_none /ra_undef_none /ra_vm. move/eqP: Export => ->. exact. - + exact: ok_res'. - + exact: wt_res'. + exact: vm2_rsp. reflexivity. - case/(_ lm vm (linear_body liparams p fn fd.(f_extra) fd.(f_body)).2 RAnone None (top_stack m) (map fst fd.(f_extra).(sf_to_save)) ok_vm M). - - move => x; rewrite !Fv.setP. + case/(_ lm vm (linear_body liparams p fn fd.(f_extra) fd.(f_body)).2 RAnone None (top_stack m) (map fst fd.(f_extra).(sf_to_save)) M). + - move => x; rewrite !Vm.setP vm_truncate_val_eq //. case: eqP => ?; first by subst; rewrite vm_rsp. case: eqP => ?; first subst. + move/allP: safe_registers => /(_ var_tmp). rewrite inE eqxx => /(_ erefl). rewrite /get_var. - by case: _.[_]%vmap => // - []. + by case: _.[_] => // - []. by []. - by eexists; first exact: get_fundef_p' ok_fd. - eexists; first exact: ok_fd. @@ -4079,43 +3975,38 @@ Section PROOF. - eexists; first exact: ok_fd. by move/eqP: Export => /= ->. - by move: safe_registers; rewrite /= Export {1}/vm_initialized_on /= => /andP[] _. - move => lmo vmo texec vm_eq_vmo ? s2_vmo ? M'. - have vm2_vmo : ∀ r, List.In r (f_res fd) → (eval_uincl vm2.[r] vmo.[r])%vmap. + move => lmo vmo texec vm_eq_vmo s2_vmo ? M'. + have vm2_vmo : ∀ r, List.In r (f_res fd) → (value_uincl vm2.[r] vmo.[r]). - move => r r_in_result. have r_not_saved : ¬ Sv.In r (sv_of_list id (map fst fd.(f_extra).(sf_to_save))). + apply/Sv_memP. rewrite sv_of_listE map_id -sv_of_listE; apply/Sv_memP => K. move/disjointP: to_save_not_result => /(_ _ K). by apply; apply/Sv_memP; rewrite sv_of_listE; apply/in_map; exists r. - apply: eval_uincl_trans (s2_vmo r r_not_saved). + apply: value_uincl_trans (s2_vmo r r_not_saved). have r_not_rsp : vrsp != r. + apply/eqP => K. by move: RSP_not_result; rewrite sv_of_listE; apply/negP/negPn/in_map; exists r. - by rewrite !Fv.setP_neq. + by rewrite !Vm.setP_neq. have : ∃ lres : values, - [/\ mapM (λ x : var_i, get_var vmo x) (f_res fd) = ok lres, List.Forall2 value_uincl res lres & all2 check_ty_val (f_tyout fd) lres ]. + [/\ mapM (λ x : var_i, get_var false vmo x) (f_res fd) = ok lres & List.Forall2 value_uincl res lres ]. { - move/mapM_Forall2: ok_res' res_res' (f_tyout fd) wt_res' vm2_vmo. + move/mapM_Forall2: ok_res' res_res' vm2_vmo. move: res' res (f_res fd). elim => [ | r' res' ih ]. - + move => _ _ /List_Forall2_inv_r-> /List_Forall2_inv_r -> [] // _ _. + + move => _ _ /List_Forall2_inv_r-> /List_Forall2_inv_r -> _. by exists [::]. - move => _ _ /List_Forall2_inv_r[] d [] ds [] -> [] ok_r' ok_res' /List_Forall2_inv_r[] r [] res [] -> [] r_r' res_res'. - case => // ty tys /= /andP[] wt_r' wt_res' vm2_vmo. + move => _ _ /List_Forall2_inv_r[] d [] ds [] -> [] ok_r' ok_res' /List_Forall2_inv_r[] r [] res [] -> [] r_r' res_res' vm2_vmo. have := vm2_vmo d (or_introl _ erefl). - move: ok_r'; rewrite {1 3}/get_var. - case: vm2.[d]%vmap => [ | [] // ] /= v /ok_inj ?; subst r'. - case: vmo.[d]%vmap => // v' v_v' /=. - move: ih => /(_ _ _ ok_res' res_res' _ wt_res')[]. + move: ok_r'; rewrite {1}/get_var /= => -[?] v_v'; subst r'. + move: ih => /(_ _ _ ok_res' res_res') []. + by move => x hx; apply: vm2_vmo; right. - move => lres [] -> /= res_lres wt_lres. + move => lres [] -> /= res_lres. eexists; split; first reflexivity. - + constructor; last by []. - exact: value_uincl_trans v_v'. - rewrite /= wt_lres andbT. - exact: check_ty_val_uincl v_v'. + constructor => //. + by apply: value_uincl_trans r_r' v_v'. } - case => lres [] ok_lres res_lres wt_lres. + case => lres [] ok_lres res_lres. exists vmo, lmo, lres; split. - econstructor; first exact: get_fundef_p' ok_fd. + exact: Export. @@ -4130,10 +4021,8 @@ Section PROOF. apply: S. by rewrite Sv.inter_spec. - exact: M'. - - move/eqP: Export => /= -> /=. - exact: ok_lres. - - exact: res_lres. - exact: wt_lres. + - move/eqP: Export => /= -> //=. + exact: res_lres. Qed. End PROOF. diff --git a/proofs/compiler/makeReferenceArguments.v b/proofs/compiler/makeReferenceArguments.v index 8a2f50918..58387ef19 100644 --- a/proofs/compiler/makeReferenceArguments.v +++ b/proofs/compiler/makeReferenceArguments.v @@ -7,7 +7,6 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope vmap. Local Open Scope seq_scope. Module Import E. @@ -86,21 +85,11 @@ Fixpoint make_pseudo_epilogue (ii:instr_info) (X:Sv.t) ctr xtys rs := Definition mk_ep_i ii r ty y := MkI ii (Cassgn r AT_rename ty (Plvar y)). -Fixpoint noload (e:pexpr) := - match e with - | Pload _ _ _ => false - | Pconst _ | Pbool _ | Parr_init _ | Pvar _ => true - | Pget _ _ _ e | Psub _ _ _ _ e | Papp1 _ e => noload e - | Papp2 _ e1 e2 => noload e1 && noload e2 - | PappN _ es => all noload es - | Pif _ e1 e2 e3 => [&& noload e1, noload e2 & noload e3] - end. - Definition wf_lv (lv:lval) := match lv with | Lnone _ _ | Lmem _ _ _ | Laset _ _ _ _ => false | Lvar _ => true - | Lasub _ _ _ _ e => noload e + | Lasub _ _ _ _ e => ~~use_mem e end. Fixpoint swapable (ii:instr_info) (pis : seq pseudo_instr) := diff --git a/proofs/compiler/makeReferenceArguments_proof.v b/proofs/compiler/makeReferenceArguments_proof.v index d1430e38d..2644e6b09 100644 --- a/proofs/compiler/makeReferenceArguments_proof.v +++ b/proofs/compiler/makeReferenceArguments_proof.v @@ -8,12 +8,13 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope vmap. Local Open Scope seq_scope. Section SemInversion. Context + {wsw : WithSubWord} + {dc:DirectCall} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} @@ -52,12 +53,15 @@ End SemInversion. Section WITH_PARAMS. Context + {wsw : WithSubWord} {asm_op syscall_state : Type} {eparams : EstateParams syscall_state} {spparams : SemPexprParams} {siparams : SemInstrParams asm_op syscall_state} (fresh_id : instr_info → Ident.name → stype → Ident.ident). +#[local] Existing Instance indirect_c. + Lemma make_referenceprog_globs (p p' : uprog) : makereference_prog fresh_id p = ok p' -> p.(p_globs) = p'.(p_globs). @@ -109,7 +113,7 @@ Context Inductive sem_pis ii : estate -> seq pseudo_instr -> values -> estate -> Prop := | SPI_nil : forall s, sem_pis ii s [::] [::] s | SPI_lv : forall s1 s2 s3 lv pis v vs, - write_lval (p_globs p') lv v s1 = ok s2 -> + write_lval true (p_globs p') lv v s1 = ok s2 -> sem_pis ii s2 pis vs s3 -> sem_pis ii s1 (PI_lv lv :: pis) (v::vs) s3 | SPI_i : forall s1 s2 s3 lv ty y pis vs, @@ -123,10 +127,10 @@ Context | [::] => vs = [::] ∧ s3 = s1 | PI_lv lv :: pis' => ∃ v vs' s2, - [/\ vs = v ::vs', write_lval (p_globs p') lv v s1 = ok s2 & sem_pis ii s2 pis' vs' s3 ] + [/\ vs = v ::vs', write_lval true (p_globs p') lv v s1 = ok s2 & sem_pis ii s2 pis' vs' s3 ] | PI_i lv ty y :: pis' => exists2 s2, sem_I p' ev s1 (mk_ep_i ii lv ty y) s2 & sem_pis ii s2 pis' vs s3 - end. + end. Proof. case => {s1 pis vs s3}. - by []. @@ -148,52 +152,25 @@ Context by t_xrbindP => fdecls Hmap_cfprog <- /=. Qed. - Lemma truncate_val_pof_val ty v vt: - truncate_val ty v = ok vt -> - exists w, pof_val ty vt = ok w /\ pto_val w = vt. - Proof. - case: v => [b | z | len a | s ws | ty' ?]. - + by move=> /truncate_valE [??]; subst ty vt => /=; exists b. - + by move=> /truncate_valE [??]; subst ty vt => /=; exists z. - + rewrite /truncate_val; case: ty => //=. - t_xrbindP=> len' a' hc <-; eexists;split; last reflexivity. - by rewrite /to_arr WArray.castK. - + move=> /truncate_valE [ws' [? [-> ?]]] -> /=. - case: Sumbool.sumbool_of_bool; first by eauto. - by rewrite cmp_le_refl. - by move=> /truncate_valE. - Qed. - - Lemma truncate_val_idem (t : stype) (v v' : value) : - truncate_val t v = ok v' -> truncate_val t v' = ok v'. - Proof. - rewrite /truncate_val; case: t v => [||q|w]. - + by move=> x; t_xrbindP=> b bE <-. - + by move=> x; t_xrbindP=> i iE <-. - + by move=> x; t_xrbindP=> a aE <- /=; rewrite WArray.castK. - + move=> x; t_xrbindP=> w' w'E <- /=. - by rewrite truncate_word_u. - Qed. - - Lemma is_reg_ptr_lval_ty ii ctr b x ty lv y: - is_reg_ptr_lval fresh_id ii ctr b x ty lv = Some y -> vtype y = ty. + Lemma is_reg_ptr_lval_ty b ii sfx x ty lv y: + is_reg_ptr_lval fresh_id ii sfx b x ty lv = Some y -> vtype y = ty. Proof. by case: lv => //= [? | _ _ _ ? _ [<-] //]; case: ifP => // _ [<-]. Qed. - Lemma make_pseudo_codeP ii X ctr xtys lvs pis s1 s2 vm1 vs vst: - make_pseudo_epilogue fresh_id ii X ctr xtys lvs = ok pis -> - mapM2 ErrType truncate_val (map snd xtys) vs = ok vst -> + Lemma make_pseudo_codeP ii sfx X xtys lvs pis s1 s2 vm1 vs vst: + make_pseudo_epilogue fresh_id ii X sfx xtys lvs = ok pis -> + mapM2 ErrType dc_truncate_val (map snd xtys) vs = ok vst -> Sv.Subset (Sv.union (read_rvs lvs) (vrvs lvs)) X -> - write_lvals (p_globs p) s1 lvs vst = ok s2 -> + write_lvals true (p_globs p) s1 lvs vst = ok s2 -> evm s1 =[X] vm1 -> exists2 vm2,sem_pis ii (with_vm s1 vm1) pis vst (with_vm s2 vm2) & evm s2 =[X] vm2. Proof. - move=> h; elim /make_pseudo_epilogueW : h s1 vm1 vs vst => {ctr xtys lvs pis}. + move=> h; elim /make_pseudo_epilogueW : h s1 vm1 vs vst => {xtys lvs pis}. + by move=> _ s1 vm1 [] // _ [] <- _ [<-] ?; exists vm1 => //; constructor. + move=> ctr b x ty xtys lv lvs pis hnone _ ih s1 vm1 [ //| v vs] vst' /=. t_xrbindP => vt ht vst hts <- {vst'}. rewrite read_rvs_cons vrvs_cons => leX /=. t_xrbindP => s1' hw hws eqvm. - have [|vm1' [eqvm' hw']]:= write_lval_eq_on _ hw eqvm; first by SvD.fsetdec. + have [|vm1' hw' eqvm']:= write_lval_eq_on _ hw eqvm; first by SvD.fsetdec. case: (ih _ vm1' _ _ hts _ hws _). - by SvD.fsetdec. - by apply: eq_onI eqvm'; SvD.fsetdec. @@ -206,19 +183,21 @@ Context t_xrbindP => s1' hw hws eqvm. have ? := is_reg_ptr_lval_ty hsome; subst ty. have [vmy [hw' eqvmy semy]]: exists vmy, - [/\ write_lval (p_globs p') y vt (with_vm s1 vm1) = ok (with_vm s1 vmy), + [/\ write_lval true (p_globs p') y vt (with_vm s1 vm1) = ok (with_vm s1 vmy), evm s1 =[X] vmy & - sem_pexpr (p_globs p') (with_vm s1 vmy) (Plvar y) = ok vt]. - + rewrite /write_lval /= /write_var evm_with_vm /set_var. - case: (truncate_val_pof_val ht) => w [-> /= ?]; subst vt. - exists (vm1.[y <- ok w]); split => //. - - move=> z hz; rewrite Fv.setP_neq; first by apply eqvm. - by apply/eqP => ?;subst z;SvD.fsetdec. - by rewrite /get_gvar /= /get_var Fv.setP_eq. + sem_pexpr true (p_globs p') (with_vm s1 vmy) (Plvar y) = ok vt]. + + have heqt := truncate_val_has_type ht. + rewrite /= (write_var_eq_type heqt (truncate_val_DB true ht)). + eexists; split; first reflexivity. + move=> z hz; rewrite Vm.setP_neq; first by apply eqvm. + + by apply/eqP => ?;subst z;SvD.fsetdec. + assert (htr := truncatable_type_of true vt). + move: htr; rewrite heqt => htr. + by rewrite /get_gvar /= get_var_eq //= (truncate_val_defined ht) (vm_truncate_val_eq heqt). set I := mk_ep_i ii lv (vtype y) y. have [vm1' semI eqvm1']: exists2 vm1', sem_I p' ev (with_vm s1 vmy) I (with_vm s1' vm1') & evm s1' =[X] vm1'. - + have [ | vm1' [eqvm1' hwvm1']]:= write_lval_eq_on (X:=X) _ hw eqvmy;first by SvD.fsetdec. + + have [ | vm1' hwvm1 eqvm1' ]:= write_lval_eq_on (X:=X) _ hw eqvmy;first by SvD.fsetdec. exists vm1'; last by apply: eq_onI eqvm1'; SvD.fsetdec. constructor; apply Eassgn with vt vt => //. - by apply: truncate_val_idem ht. @@ -227,220 +206,12 @@ Context exists vm2 => //; econstructor; eauto; econstructor; eauto. Qed. - (* FIXME : Move the section in psem *) - Section Sem_eqv. - - Let Pc s1 c s2 := - forall vm1 X, - Sv.Subset (read_c c) X -> - evm s1 =[X] vm1 -> - exists vm2, sem p' ev (with_vm s1 vm1) c (with_vm s2 vm2) /\ evm s2 =[X] vm2. - - Let Pi s1 (i:instr) s2 := - forall vm1 X, - Sv.Subset (read_I i) X -> - evm s1 =[X] vm1 -> - exists vm2, sem_I p' ev (with_vm s1 vm1) i (with_vm s2 vm2) /\ evm s2 =[X] vm2. - - Let Pi_r s1 (i:instr_r) s2 := - forall vm1 X, - Sv.Subset (read_i i) X -> - evm s1 =[X] vm1 -> - exists vm2, sem_i p' ev (with_vm s1 vm1) i (with_vm s2 vm2) /\ evm s2 =[X] vm2. - - Let Pfor (i:var_i) zs s1 c s2 := - forall vm1 X, - Sv.Subset (read_c c) X -> - evm s1 =[X] vm1 -> - exists vm2, sem_for p' ev i zs (with_vm s1 vm1) c (with_vm s2 vm2) /\ evm s2 =[X] vm2. - - Let Pfun (scs:syscall_state) (m:mem) (fn:funname) (args: values) (scs':syscall_state) (m':mem) (res:values) := true. - - Lemma read_cP X s1 c s2 vm1 : - sem p' ev s1 c s2 -> - Sv.Subset (read_c c) X -> - evm s1 =[X] vm1 -> - exists vm2, sem p' ev (with_vm s1 vm1) c (with_vm s2 vm2) /\ evm s2 =[X] vm2. - Proof. - move=> hsem;move: hsem vm1 X. - apply : (sem_Ind (Pc := Pc) (Pi := Pi) (Pi_r := Pi_r) (Pfor := Pfor) (Pfun := Pfun)) => {s1 c s2}. - + by move=> s vm1 X hsub heq; exists vm1; split => //;constructor. - + move=> s1 s2 s3 i c _ ihi _ ihc vm1 X; rewrite read_c_cons => hsub heq1. - case: (ihi vm1 X _ heq1); first by SvD.fsetdec. - move=> vm2 [hi heq2]. - case: (ihc vm2 X _ heq2); first by SvD.fsetdec. - by move=> vm3 [hc heq3]; exists vm3;split => //; econstructor; eauto. - + move=> ii i s1 s2 _ ih vm1 X; rewrite read_Ii => hsub heq1. - by case: (ih vm1 X hsub heq1) => vm2 [??];exists vm2; split. - + move=> s1 s2 x t ty e v v' he htr hw vm1 X. - rewrite read_i_assgn => hsub heq1. - case: (write_lval_eq_on _ hw heq1); first by SvD.fsetdec. - move=> vm2 [ heq2 ?];exists vm2; split. - + econstructor; eauto. - rewrite -read_e_eq_on_empty //. - by rewrite read_eE => z hz; apply heq1; SvD.fsetdec. - by move=> z hz;apply heq2; SvD.fsetdec. - + move=> s1 s2 t o xs es. - rewrite /sem_sopn; t_xrbindP => vargs vres hes hex hw vm1 X. - rewrite read_i_opn => hsub heq1. - case: (write_lvals_eq_on _ hw heq1); first by SvD.fsetdec. - move=> vm2 [heq2 hw2]; exists vm2; split => //. - econstructor; eauto. - rewrite /sem_sopn -(read_es_eq_on _ (s := X)) //; last first. - + by move=> z;rewrite read_esE => hz;apply heq1; SvD.fsetdec. - by rewrite hes /= hex /= hw2. - by apply: eq_onI heq2; SvD.fsetdec. - + move=> s1 scs m s2 o xs es ves vs hes ho hw vm1 X. - rewrite read_i_syscall => hsub heq1. - case: (write_lvals_eq_on _ hw heq1); first by SvD.fsetdec. - move=> vm2 [heq2 hw2]; exists vm2; split => //. - econstructor; eauto. - rewrite -(read_es_eq_on _ (s := X)) //; last first. - + by move=> z;rewrite read_esE => hz;apply heq1; SvD.fsetdec. - by apply: eq_onI heq2; SvD.fsetdec. - + move=> s1 s2 e c1 c2 he _ ih vm1 X. - rewrite read_i_if => hsub heq1. - case: (ih vm1 X _ heq1); first SvD.fsetdec. - move=> vm2 [hs2 heq2]; exists vm2;split => //. - apply Eif_true => //. - rewrite -read_e_eq_on_empty //. - by rewrite read_eE; apply: eq_onI heq1; SvD.fsetdec. - + move=> s1 s2 e c1 c2 he _ ih vm1 X. - rewrite read_i_if => hsub heq1. - case: (ih vm1 X _ heq1); first SvD.fsetdec. - move=> vm2 [hs2 heq2]; exists vm2;split => //. - apply Eif_false => //. - rewrite -read_e_eq_on_empty //. - by rewrite read_eE; apply: eq_onI heq1; SvD.fsetdec. - + move=> s1 s2 s3 s4 a c1 e c2 _ ih1 he _ ih2 _ ihw vm1 X. - rewrite read_i_while => hsub heq1. - case: (ih1 vm1 X _ heq1); first SvD.fsetdec. - move=> vm2 [hs1 heq2]; case: (ih2 vm2 X _ heq2); first SvD.fsetdec. - move=> vm3 [hs2 heq3]; case: (ihw vm3 X _ heq3); first by rewrite read_i_while. - move=> vm4 [hs3 heq4]; exists vm4; split => //. - apply: Ewhile_true; eauto. - rewrite -read_e_eq_on_empty //. - by rewrite read_eE; apply: eq_onI heq2; SvD.fsetdec. - + move=> s1 s2 a c1 e c2 _ ih1 he vm1 X. - rewrite read_i_while => hsub heq1. - case: (ih1 vm1 X _ heq1); first SvD.fsetdec. - move=> vm2 [hs1 heq2]; exists vm2; split => //. - apply: Ewhile_false; eauto. - rewrite -read_e_eq_on_empty //. - by rewrite read_eE; apply: eq_onI heq2; SvD.fsetdec. - + move=> s1 s2 i d lo hi c vlo vhi hlo hhi _ ih vm1 X. - rewrite read_i_for => hsub heq1. - case: (ih vm1 X _ heq1); first by SvD.fsetdec. - move=> vm2 [? heq2]; exists vm2; split => //. - by econstructor; - eauto; - rewrite -read_e_eq_on_empty // read_eE; - apply: eq_onI heq1; SvD.fsetdec. - + move=> s1 i c vm1 X hsub heq1. - by exists vm1; split => //;constructor. - + move=> s1 s2 s3 s4 i z zs c hwi _ ihc _ ihf vm1 X hsub heq1. - case: (write_var_eq_on hwi heq1) => vm2 [heq2 hw2]. - case: (ihc vm2 X hsub); first by apply: eq_onI heq2; SvD.fsetdec. - move=> vm3 [? heq3]. - case: (ihf vm3 X hsub heq3) => vm4 [? heq4]; exists vm4; split => //. - by econstructor; eauto. - + move=> s1 scs2 m2 s2 ii xs fn args vargs vs hargs hcall _ hw vm1 X. - rewrite read_i_call => hsub heq1. - case: (write_lvals_eq_on _ hw heq1); first by SvD.fsetdec. - move=> vm2 [heq2 hw2]; exists vm2; split; last by apply: eq_onI heq2; SvD.fsetdec. - econstructor; eauto. - by rewrite -(read_es_eq_on _ (s := X)) // read_esE; - apply: eq_onI heq1; - SvD.fsetdec. - done. - Qed. - - Lemma sem_eqv s1 c s2 vm1: - sem p' ev s1 c s2 -> - evm s1 =v vm1 -> - exists vm2, sem p' ev (with_vm s1 vm1) c (with_vm s2 vm2) /\ evm s2 =v vm2. - Proof. - move=> hsem heq1. - case: (read_cP (vm1 := vm1) (X:= Sv.union (read_c c) (write_c c)) hsem). - + by SvD.fsetdec. - + by move=> x hx;apply heq1. - move=> vm2 [hsem2 heq2]; exists vm2; split => //. - move=> x; case: (Sv_memP x (write_c c)) => hx. - + by apply heq2; SvD.fsetdec. - rewrite -(writeP hsem) // heq1. - by have := writeP hsem2; rewrite !evm_with_vm => ->. - Qed. - - Lemma set_var_spec x v vm1 vm2 vm1' : - set_var vm1 x v = ok vm2 -> - exists vm2', [/\ set_var vm1' x v = ok vm2', vm1' = vm2' [\ Sv.singleton x] & vm2'.[x] = vm2.[x] ]. - Proof. - rewrite /set_var. - apply: set_varP => [ w -> | -> ->] /= <-. - + exists vm1'.[x <- ok w]; split => //; last by rewrite !Fv.setP_eq. - by move=> z hz; rewrite Fv.setP_neq //; apply/eqP; SvD.fsetdec. - exists vm1'.[x <- pundef_addr (vtype x)]; split => //; last by rewrite !Fv.setP_eq. - by move=> z hz; rewrite Fv.setP_neq //; apply/eqP; SvD.fsetdec. - Qed. - - Lemma write_var_spec x v s1 s2 s1': - write_var x v s1 = ok s2 -> - exists vmx, [/\ write_var x v s1' = ok (with_vm s1' vmx), - evm s1' = vmx [\ Sv.singleton x] & vmx.[x] = (evm s2).[x]]. - Proof. - rewrite /write_var; t_xrbindP => vm hs <- {s2}. - by have [vmx [-> ?? /=]] := set_var_spec (evm s1') hs; exists vmx. - Qed. - - End Sem_eqv. - - (* FIXME: move this in psem *) - Lemma sem_pexpr_noload gd s1 s2 e v: - evm s1 = evm s2 -> noload e -> - sem_pexpr gd s1 e = ok v -> - sem_pexpr gd s2 e = ok v. - Proof. - move=> hs. - pose (P e := - forall v, - noload e → - sem_pexpr gd s1 e = ok v → - sem_pexpr gd s2 e = ok v). - pose (Q es := - forall vs, - all noload es -> sem_pexprs gd s1 es = ok vs → - sem_pexprs gd s2 es = ok vs). - apply: (pexpr_mut_ind (P:= P) (Q:= Q))=> {e v}; split; rewrite /P /Q /= ?hs // => {P Q}. - + move=> e ihe es ihes vs /andP [] /ihe{ihe}ihe /ihes{ihes}ihes. - by t_xrbindP => ? /ihe -> /= ? /ihes -> /= <-. - + move=> aa sz x e ih v /ih{ih}ih. - apply: on_arr_gvarP => n t hx ->. - by rewrite /on_arr_var /=; t_xrbindP => ze ve /ih -> /= -> ? /= -> <-. - + move=> aa sz len x e ih v /ih{ih}ih. - apply: on_arr_gvarP => n t hx ->. - by rewrite /on_arr_var /=; t_xrbindP => ze ve /ih -> /= -> ? /= -> <-. - + by move=> o e ih v /ih{ih}ih; t_xrbindP => ve /ih -> /= ->. - + move=> o e1 ih1 e2 ih2 v /andP [] /ih1{ih1}ih1 /ih2{ih2}ih2. - by t_xrbindP => ve1 /ih1 -> /= ve2 /ih2 -> /=. - + move=> e es ihes v /ihes{ihes}ihes; t_xrbindP => ? /ihes. - by rewrite /sem_pexprs => -> /=. - move=> t e ihe e1 ihe1 e2 ihe2 v /and3P [] he he1 he2. - by t_xrbindP => ?? /(ihe _ he) -> /= -> ?? /(ihe1 _ he1) -> /= -> ?? /(ihe2 _ he2) -> /= -> <-. - Qed. - - (* FIXME: move this in psem *) - Lemma sem_pexpr_noload_eq_on gd s1 s2 e v: - noload e -> evm s1 =[read_e e] evm s2 -> - sem_pexpr gd s1 e = ok v -> - sem_pexpr gd s2 e = ok v. - Proof. by move=> hl hvm; rewrite (eq_on_sem_pexpr (s':= with_vm s1 (evm s2))) //; apply sem_pexpr_noload. Qed. - Lemma swapableP ii pis lvs vs c s1 s2: swapable ii pis = ok (lvs, c) -> sem_pis ii s1 pis vs s2 -> exists s1' vm2, - [/\ write_lvals (p_globs p') s1 lvs vs = ok s1', - sem p' ev s1' c (with_vm s2 vm2) & Fv.ext_eq (evm s2) vm2]. + [/\ write_lvals true (p_globs p') s1 lvs vs = ok s1', + sem p' ev s1' c (with_vm s2 vm2) & evm s2 =1 vm2]. Proof. elim: pis lvs c vs s1 => /= [ | pi pis ih] lvs' c' vs s1. + case/ok_inj => <- <-{lvs' c'} /sem_pisE[] -> <- {vs s1}. @@ -460,19 +231,19 @@ Context have nwm_pi : ~~ lv_write_mem lv by case: (lv) wflv. have heqm := lv_write_memP nwm_pi H3. have heqs := lv_write_scsP H3. - have [{nwm_pi} vm3 [hvm3 hw3]] := write_lvals_eq_on (@SvP.MP.subset_refl _) hws heqr. - have hy : sem_pexpr (p_globs p') (with_vm s1' vm3) (Plvar y) = ok v. - + rewrite -H; rewrite /=; apply: (get_gvar_eq_on _ (@SvP.MP.subset_refl _)). + have [{nwm_pi} vm3 hw3 hvm3] := write_lvals_eq_on (@SvP.MP.subset_refl _) hws heqr. + have hy : sem_pexpr true (p_globs p') (with_vm s1' vm3) (Plvar y) = ok v. + + rewrite -H; rewrite /=; apply: (get_gvar_eq_on _ _ (@SvP.MP.subset_refl _)). rewrite /read_gvar /= => y' /SvD.F.singleton_iff ?; subst y'. have := (disjoint_eq_ons (s:= Sv.singleton y) _ hw3). rewrite !evm_with_vm => <- //; last by SvD.fsetdec. apply/Sv.is_empty_spec; move/Sv.is_empty_spec: hwr. by rewrite /read_I_rec /write_I_rec /= read_rvE /read_gvar /=; SvD.fsetdec. - have heqnw: evm s1' = vm3 [\ Sv.union (vrv lv) (vrvs lvs)]. + have heqnw: evm s1' =[\ Sv.union (vrv lv) (vrvs lvs)] vm3. + move=> x hx; have /= <- := vrvsP hw3; last by SvD.fsetdec. rewrite -(vrvsP hws); last by SvD.fsetdec. by rewrite -(vrvP H3) //; SvD.fsetdec. - have [vmi [hsemi heqv]]: exists vmi, write_lval (p_globs p') lv v' (with_vm s1' vm3) = ok (with_vm s1' vmi) /\ evm s1' =v vmi. + have [vmi [hsemi heqv]]: exists vmi, write_lval true (p_globs p') lv v' (with_vm s1' vm3) = ok (with_vm s1' vmi) /\ evm s1' =1 vmi. + move: H3; rewrite /write_lval. move /Sv.is_empty_spec: hwr; move /Sv.is_empty_spec: hrw. rewrite /read_I_rec /write_I_rec [X in (Sv.inter (vrvs _) X)]/= /read_gvar @@ -489,15 +260,14 @@ Context apply: on_arr_varP => sz t htyx hget. rewrite /write_var. t_xrbindP=> zi vi he hvi t1 -> t1' hsub vms3 hset ?; subst s3; rewrite /on_arr_var. - rewrite (@get_var_eq_on (Sv.singleton x) (evm s1)); first last. + rewrite (@get_var_eq_on _ _ (Sv.singleton x) (evm s1)); first last. + by move=> z hz; have := vrvsP hw3; rewrite !evm_with_vm => -> //; SvD.fsetdec. + by SvD.fsetdec. rewrite hget /=. - have -> := sem_pexpr_noload_eq_on hnoload _ he; last first. + rewrite -(use_memP_eq_on _ _ (s1:= s1) hnoload) ?he; last first. + rewrite evm_with_vm; rewrite /with_vm /= in hw3 => z hz. by have /= -> // := vrvsP hw3; move: hwr; rewrite read_eE; SvD.fsetdec. rewrite /= hvi /= hsub /=. - have [vmi [-> hvmi hx]]:= set_var_spec vm3 hset; exists vmi; split => //. move=> z; case: ((v_var x) =P z) => hxz. + by subst z; rewrite hx; have /= -> // := vrvsP hws; SvD.fsetdec. @@ -505,12 +275,12 @@ Context by case (Sv_memP z (vrvs lvs)) => hz; [apply hvm3 | apply heqnw]; SvD.fsetdec. set I := (MkI _ _). have hsemI : sem_I p' ev (with_vm s1' vm3) I (with_vm s1' vmi) by constructor; econstructor; eauto. - have [vm4 []]:= sem_eqv hsem heqv. + have [vm4 ]:= sem_vm_eq hsem heqv. rewrite with_vm_idem => {hsem}hsem heqvm4. exists (with_vm s1' vm3), vm4; split. + by have -> // : s1 = (with_vm s3 (evm s1)); rewrite /with_vm -heqm -heqs; case: (s1). + by econstructor;eauto. - by move=> x; rewrite (heqvm x) (heqvm4 x). + by move=> x; rewrite (heqvm x) // (heqvm4 x). Qed. Let Pi s1 (i:instr) s2:= @@ -564,11 +334,11 @@ Context Proof. move=> s1 s2 x t ty e v v' he htr hw ii X c' [<-]. rewrite read_Ii /write_I /write_I_rec vrv_recE read_i_assgn => hsub vm1 hvm1. - move: he; rewrite (read_e_eq_on_empty _ (vm := vm1)); last first. + move: he; rewrite (read_e_eq_on_empty _ _ (vm := vm1)); last first. + by apply: eq_onI hvm1; rewrite read_eE; SvD.fsetdec. - rewrite eq_globs => he; case: (write_lval_eq_on _ hw hvm1). + rewrite eq_globs => he; have [|vm2 ? eq_s2_vm2]:= write_lval_eq_on _ hw hvm1. + by SvD.fsetdec. - move => vm2 [eq_s2_vm2 H_write_lval]; exists vm2. + exists vm2. + by apply: (eq_onI _ eq_s2_vm2); SvD.fsetdec. by apply/sem_seq1/EmkI/(Eassgn _ _ he htr); rewrite -eq_globs. Qed. @@ -580,10 +350,10 @@ Context move: He; rewrite eq_globs /sem_sopn Let_Let. t_xrbindP => vs Hsem_pexprs res Hexec_sopn hw. case: (write_lvals_eq_on _ hw hvm1); first by SvD.fsetdec. - move=> vm2 [eq_s2_vm2 H_write_lvals]; exists vm2. + move=> vm2 ? eq_s2_vm2; exists vm2. + by apply: (eq_onI _ eq_s2_vm2); SvD.fsetdec. apply/sem_seq1/EmkI; constructor. - rewrite /sem_sopn Let_Let -(read_es_eq_on _ (s := X)); last first. + rewrite /sem_sopn Let_Let -(read_es_eq_on _ _ (s := X)); last first. + by rewrite read_esE; apply: (eq_onI _ hvm1); SvD.fsetdec. by rewrite Hsem_pexprs /= Hexec_sopn. Qed. @@ -668,7 +438,7 @@ Context Proof. move => s1 s2 s3 s4 x w ws c eq_s2 sem_s2_s3 H_s2_s3 H_s3_s4 Pfor_s3_s4 X c'. move => eq_c' le_X vm1 eq_s1_vm1. - case : (write_var_eq_on eq_s2 eq_s1_vm1) => vm2 [eq_s2_vm2 eq_write]. + case : (write_var_eq_on eq_s2 eq_s1_vm1) => vm2 eq_write eq_s2_vm2. case : (H_s2_s3 X _ eq_c' _ vm2). + by SvD.fsetdec. + by apply: (eq_onI _ eq_s2_vm2) ; SvD.fsetdec. @@ -700,36 +470,18 @@ Context is_reg_ptr_expr fresh_id ii ctr b x ty lv = Some y -> vtype y = ty. Proof. by case: lv => //= [? | _ _ _ ? _ [<-] //]; case: ifP => // _ [<-]. Qed. - (* FIXME: move this *) - Definition is_Vundef v := - if v is Vundef _ _ then true else false. - - Lemma to_val_def t (v:sem_t t) : ~~is_Vundef (to_val v). - Proof. case: t v => //. Qed. - - Lemma pof_val_type_of_val (v: value) : - ~~is_Vundef v -> - exists2 x, pof_val (type_of_val v) v = ok x & pto_val x = v. - Proof. - case: v => //=; eauto. - + by move=> n a _; rewrite WArray.castK /=; exists a. - move => sz w _; rewrite (sumbool_of_boolET (cmp_le_refl sz)). - eexists; split; eauto. - Qed. - (* End FIXME: move this *) - Lemma make_prologueP X ii s: forall xfty ctr args Y pl args', make_prologue fresh_id ii Y ctr xfty args = ok (pl, args') -> Sv.Subset X Y -> Sv.Subset (read_es args) X -> forall vargs vs vm1, - sem_pexprs (p_globs p) s args = ok vargs -> + sem_pexprs true (p_globs p) s args = ok vargs -> mapM2 ErrType truncate_val (map snd xfty) vargs = ok vs -> evm s =[X] vm1 -> exists vm2 vargs', [/\ sem p' ev (with_vm s vm1) pl (with_vm s vm2), - sem_pexprs (p_globs p') (with_vm s vm2) args' = ok vargs', + sem_pexprs true (p_globs p') (with_vm s vm2) args' = ok vargs', mapM2 ErrType truncate_val (map snd xfty) vargs' = ok vs & vm1 =[Y] vm2]. Proof. @@ -744,41 +496,39 @@ Context + move=> [c args'] hmk [<- <-] {_pl _args'}. have [vm2 [vargs' [h1 h2 h3 h4]]]:= ih _ _ _ _ _ hmk hXY hasX _ _ vm1 hvargs hvs heqvm. exists vm2, [:: va & vargs']; split => //=; last by rewrite hv h3. - rewrite -(eq_on_sem_pexpr _ (s:= s)) //=; last first. + rewrite -(eq_on_sem_pexpr _ _ (s:= s)) //=; last first. + by apply (eq_onT (vm2:= vm1));[apply: eq_onI heqvm => //| apply: eq_onI h4; SvD.fsetdec ]. by rewrite h2 -(make_referenceprog_globs Hp) hva. move=> /Sv_memP hnin [c args'] hmk [<- <-]{_pl _args'}. have ? := is_reg_ptr_expr_ty E; subst ty. - pose vm1' := vm1.[y <- pof_val (vtype y) v]. - have v_def : ~~is_Vundef v. - + by move: (hv); rewrite /truncate_val; t_xrbindP => v' _ ?; subst v; apply to_val_def. - have hset : set_var vm1 y v = ok vm1'. - + rewrite /vm1'; have hty:= sym_eq (truncate_val_has_type hv); have := set_well_typed_var vm1 hty. - by case: (v) v_def. + + pose vm1' := vm1.[y <- v]. have [|| vm2 [vargs' [h1 h2 h3 h4]]]:= ih _ _ _ _ _ hmk _ hasX _ _ vm1' hvargs hvs. + by SvD.fsetdec. - + by apply: (eq_onT heqvm)=> z hz; rewrite /vm1' Fv.setP_neq //; apply/eqP => h;apply hnin; SvD.fsetdec. - exists vm2, [::v & vargs']; split => //; first last. + + by apply: (eq_onT heqvm)=> z hz; rewrite /vm1' Vm.setP_neq //; apply/eqP => h;apply hnin; SvD.fsetdec. + exists vm2, [:: v & vargs']; split => //; first last. + apply (eq_onT (vm2:= vm1')); last by apply: eq_onI h4; SvD.fsetdec. - by move=> z hz; rewrite /vm1' Fv.setP_neq //; apply/eqP => h;apply hnin; SvD.fsetdec. + by move=> z hz; rewrite /vm1' Vm.setP_neq //; apply/eqP => h;apply hnin; SvD.fsetdec. + by rewrite (truncate_val_idem hv) h3. + rewrite /= /get_gvar /= /get_var -(h4 y); last by SvD.fsetdec. - rewrite /on_vu /vm1' Fv.setP_eq -(truncate_val_has_type hv) h2. - by have [? -> ->] /= := pof_val_type_of_val v_def. + rewrite /vm1' Vm.setP_eq /= vm_truncate_val_eq; last by apply: truncate_val_has_type hv. + by rewrite (truncate_val_defined hv) /= h2. apply: Eseq h1; apply/EmkI; econstructor; eauto. + rewrite -hva -(make_referenceprog_globs Hp); apply eq_on_sem_pexpr => //. by rewrite evm_with_vm; apply/eq_onS/eq_onI/heqvm. - by rewrite /write_lval /write_var hset /= with_vm_idem. + rewrite /write_lval; apply/write_var_eq_type. + + by apply: truncate_val_has_type hv. + by apply: truncate_val_DB hv. Qed. Lemma make_epilogueP X ii s1 s2 xfty lv lv' ep vres vs vm1 : make_epilogue fresh_id ii X xfty lv = ok (lv', ep) -> Sv.Subset (Sv.union (read_rvs lv) (vrvs lv)) X -> - write_lvals (p_globs p) s1 lv vs = ok s2 -> + write_lvals true (p_globs p) s1 lv vs = ok s2 -> mapM2 ErrType truncate_val (map snd xfty) vres = ok vs -> evm s1 =[X] vm1 -> exists vm2 s2', [/\ - write_lvals (p_globs p') (with_vm s1 vm1) lv' vs = ok s2', + write_lvals true (p_globs p') (with_vm s1 vm1) lv' vs = ok s2', sem p' ev s2' ep (with_vm s2 vm2) & evm s2 =[X] vm2]. Proof. @@ -787,7 +537,7 @@ Context have [vm2 Hsem_pis eq_s2_vm2]:= make_pseudo_codeP Hpseudo htr hsub hw heqon. have [sy [vmy] [Hwrite_lvals Hsem /= eq_vm2_vmy]]:= swapableP Hswap Hsem_pis. exists vmy, sy ; split => //. - by apply: (eq_onT eq_s2_vm2). + by apply/(eq_onT eq_s2_vm2)/vm_eq_eq_on. Qed. Local Lemma Hcall : sem_Ind_call p ev Pi_r Pfun. @@ -843,7 +593,7 @@ Context have [||x Hevms2 Hsem] := (Hs2 _ _ Hupdate_c _ (evm s1)) => //; first by SvD.fsetdec. rewrite with_vm_same in Hsem. eapply EcallRun ; try by eassumption. - rewrite -Hvres -!(sem_pexprs_get_var (p_globs p)). + rewrite -Hvres -!(sem_pexprs_get_var _ (p_globs p)). symmetry; move : Hevms2; rewrite -read_esE; apply : read_es_eq_on. Qed. @@ -853,7 +603,7 @@ Context mapM2 ErrType truncate_val [seq i.2 | i <- (get_syscall_sig o).1] ves = ok ves' & mapM2 ErrType truncate_val [seq i.2 | i <- (get_syscall_sig o).2] vs = ok vs. Proof. - case: o => len /=; t_xrbindP; rewrite /exec_getrandom => -[scs1 vs1] hex _ _ <- /=. + case: o => len /=; t_xrbindP; rewrite /exec_getrandom_u => -[scs1 vs1] hex _ _ <- /=. case: ves hex => // v [] //=; t_xrbindP => t ht t' hfill ??; subst scs1 vs1. rewrite /truncate_val /= ht /= WArray.castK; eexists; eauto. Qed. @@ -864,7 +614,7 @@ Context exec_syscall (pT := progUnit) scs m o ves = ok (scs', m', vs) -> exec_syscall (pT := progUnit) scs m o ves' = ok (scs', m', vs). Proof. - case: o => len /=; t_xrbindP; rewrite /exec_getrandom. + case: o => len /=; t_xrbindP; rewrite /exec_getrandom_u. case: ves ves' => // v [] // ves' heq [scs1 vs']. t_xrbindP => t ht t' hfill ?????; subst scs1 vs' scs' m' vs. move: heq; rewrite /truncate_val /= ht /=. diff --git a/proofs/compiler/merge_varmaps_proof.v b/proofs/compiler/merge_varmaps_proof.v index a70537af0..60b03c08b 100644 --- a/proofs/compiler/merge_varmaps_proof.v +++ b/proofs/compiler/merge_varmaps_proof.v @@ -13,7 +13,8 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope vmap_scope. +#[local] Existing Instance withsubword. +#[local] Existing Instance direct_c. Section WITH_PARAMS. @@ -28,23 +29,19 @@ Lemma init_stk_stateI fex pex gd s s' : init_stk_state fex pex gd s = ok s' → [/\ escs s = escs s', - (evm s').[vid pex.(sp_rip)] = ok (pword_of_word gd), + (evm s').[vid pex.(sp_rip)] = Vword gd, alloc_stack s.(emem) fex.(sf_align) fex.(sf_stk_sz) fex.(sf_stk_ioff) fex.(sf_stk_extra_sz) = ok (emem s'), - (evm s').[vid pex.(sp_rsp)] = ok (pword_of_word (top_stack (emem s'))) & + (evm s').[vid pex.(sp_rsp)] = Vword (top_stack (emem s')) & forall (x:var), x <> vid pex.(sp_rip) -> x <> vid pex.(sp_rsp) -> - (evm s').[x] = vmap0.[x]]. + (evm s').[x] = Vm.init.[x]]. Proof. move => /eqP checked_sp_rip. - apply: rbindP => m ok_m [<-] /=; - split => //; - rewrite -/(to_pword _ (Vword (top_stack m))); - rewrite -/(to_pword _ (Vword gd)); - rewrite !to_pword_u. - + by rewrite Fv.setP_eq. - + rewrite Fv.setP_neq. - * by rewrite Fv.setP_eq. + apply: rbindP => m ok_m [<-] /=; split => //. + + by rewrite Vm.setP_eq vm_truncate_val_eq. + + rewrite Vm.setP_neq. + * by rewrite Vm.setP_eq vm_truncate_val_eq. by apply /eqP; congruence. - by move=> x /eqP ? /eqP ?; rewrite !Fv.setP_neq // eq_sym. + by move=> x /eqP ? /eqP ?; rewrite !Vm.setP_neq // eq_sym. Qed. Lemma orbX (P Q: bool): @@ -106,11 +103,11 @@ Lemma var_tmp_not_magic : ¬ Sv.In var_tmp (magic_variables p). Proof. by move: ok_p; rewrite /check; t_xrbindP => _ _ /Sv_memP. Qed. -Record merged_vmap_precondition (W: Sv.t) (sz: wsize) (m: mem) (vm: vmap) : Prop := +Record merged_vmap_precondition (W: Sv.t) (sz: wsize) (m: mem) (vm: Vm.t) : Prop := MVP { mvp_not_written: disjoint W (magic_variables p); - mvp_top_stack: vm.[vrsp] = ok (pword_of_word (top_stack m)); - mvp_global_data : vm.[ vgd ] = ok (pword_of_word global_data); + mvp_top_stack: vm.[vrsp] = Vword (top_stack m); + mvp_global_data : vm.[ vgd ] = Vword global_data; mvp_stack_aligned : is_align (top_stack m) sz; }. @@ -232,7 +229,6 @@ Section LEMMA. mvm_scs : escs s = escs t; mvm_mem : emem s = emem t; mvm_vmap : s.(evm) <=[\D] t.(evm); - mvm_wf : wf_vm (evm t); }. Instance match_estate_m : Proper (Sv.Equal ==> eq ==> eq ==> iff) match_estate. @@ -244,7 +240,7 @@ Section LEMMA. Sv.Subset X X' → match_estate X s t → match_estate X' s t. - Proof. by move => hle [?? hvm]; split => //; apply: vmap_uincl_exI hle hvm. Qed. + Proof. by move => hle [?? hvm]; split => //; apply: uincl_exI hle hvm. Qed. Let Pc (s1: estate) (c: cmd) (s2: estate) : Prop := ∀ sz I O t1, @@ -333,13 +329,13 @@ Section LEMMA. Lemma with_vm_m x y : escs x = escs y → emem x = emem y → - with_vm x =1 with_vm y. + forall vm, with_vm x vm = with_vm y vm. Proof. by case: x y => scs m vm [] scs' m' vm' /= -> ->. Qed. - Lemma check_eP ii I e s t v u : check_e ii I e = ok u -> + Lemma check_eP wdb ii I e s t v u : check_e ii I e = ok u -> match_estate I s t -> - sem_pexpr (p_globs p) s e = ok v -> - exists2 v', sem_pexpr (p_globs p) t e = ok v' & value_uincl v v'. + sem_pexpr wdb (p_globs p) s e = ok v -> + exists2 v', sem_pexpr wdb (p_globs p) t e = ok v' & value_uincl v v'. Proof. rewrite /check_e/check_fv => /assertP/Sv.is_empty_spec hd sim sem. have := sem_pexpr_uincl_on (vm2 := evm t) _ sem. @@ -347,10 +343,10 @@ Section LEMMA. by move=> x hx; apply (mvm_vmap sim); SvD.fsetdec. Qed. - Lemma check_esP ii I es s t vs u : check_es ii I es = ok u -> + Lemma check_esP wdb ii I es s t vs u : check_es ii I es = ok u -> match_estate I s t -> - sem_pexprs (p_globs p) s es = ok vs -> - exists2 vs', sem_pexprs (p_globs p) t es = ok vs' & List.Forall2 value_uincl vs vs'. + sem_pexprs wdb (p_globs p) s es = ok vs -> + exists2 vs', sem_pexprs wdb (p_globs p) t es = ok vs' & List.Forall2 value_uincl vs vs'. Proof. rewrite /check_es => hc hsim; elim: es tt hc vs => [ | e es hrec] /=. + by move=> _ _ _ [<-]; exists [::]. @@ -362,15 +358,15 @@ Section LEMMA. Lemma check_lvP ii I x O s1 s2 t1 v v': check_lv ii I x = ok O -> match_estate I s1 t1 -> - write_lval (p_globs p) x v s1 = ok s2 -> + write_lval true (p_globs p) x v s1 = ok s2 -> value_uincl v v' -> - exists2 t2, write_lval (p_globs p) x v' t1 = ok t2 & match_estate O s2 t2. + exists2 t2, write_lval true (p_globs p) x v' t1 = ok t2 & match_estate O s2 t2. Proof. rewrite /check_lv /check_fv; t_xrbindP => /Sv.is_empty_spec hd <- hsim hw hu. have []:= write_uincl_on (vm1 := evm t1) _ hu hw. + move=> z hz; apply (mvm_vmap hsim); SvD.fsetdec. move=> vm2; rewrite (with_vm_m (mvm_scs hsim) (mvm_mem hsim)) with_vm_same => hw' hs. - exists (with_vm s2 vm2) => //;split => // [z hz | ]; last by apply: wf_write_lval hw'; case: hsim. + exists (with_vm s2 vm2) => //;split => // z hz. case: (Sv_memP z (vrv x)) => hin; first by apply hs. rewrite -(vrvP hw); last by SvD.fsetdec. rewrite -(vrvP hw'); last by SvD.fsetdec. @@ -379,9 +375,9 @@ Section LEMMA. Lemma check_lvsP ii I xs O s1 s2 t1 vs vs': check_lvs ii I xs = ok O -> match_estate I s1 t1 -> - write_lvals (p_globs p) s1 xs vs = ok s2 -> + write_lvals true (p_globs p) s1 xs vs = ok s2 -> List.Forall2 value_uincl vs vs' -> - exists2 t2, write_lvals (p_globs p) t1 xs vs' = ok t2 & match_estate O s2 t2. + exists2 t2, write_lvals true (p_globs p) t1 xs vs' = ok t2 & match_estate O s2 t2. Proof. rewrite /check_lvs. elim: xs I s1 s2 t1 vs vs' => /= [ | x xs hrec] I s1 s2 t1 [ | v vs] // vs'_. @@ -552,36 +548,17 @@ Section LEMMA. Let Pfun scs (m: mem) (fn: funname) (args: seq value) scs' (m': mem) (res: seq value) : Prop := ∀ ii fd tvm1 args', get_fundef (p_funcs p) fn = Some fd → - (* (if fd.(f_extra).(sf_return_address) is RAstack _ then extra_free_registers ii != None else true) → *) (fd.(f_extra).(sf_return_address) == RAnone) || is_align (top_stack m) fd.(f_extra).(sf_align) → - tvm1.[vrsp] = ok (pword_of_word (top_stack m)) → - tvm1.[ vgd ] = ok (pword_of_word global_data) → - wf_vm tvm1 → - mapM (λ x : var_i, get_var tvm1 x) fd.(f_params) = ok args' → + tvm1.[vrsp] = Vword (top_stack m) → + tvm1.[ vgd ] = Vword global_data → + mapM (λ x : var_i, get_var false tvm1 x) fd.(f_params) = ok args' → List.Forall2 value_uincl args args' → - ∃ (k: Sv.t) (tvm2: vmap) (res': seq value), + ∃ (k: Sv.t) tvm2 res', [/\ sem_call ii k {| escs := scs; emem := m ; evm := tvm1 |} fn {| escs := scs'; emem := m' ; evm := tvm2 |}, - wf_vm tvm2, Sv.Subset k (writefun_ra p var_tmp wrf fn), - mapM (λ x : var_i, get_var tvm2 x) fd.(f_res) = ok res' & + mapM (λ x : var_i, get_var false tvm2 x) fd.(f_res) = ok res' & List.Forall2 value_uincl res res' ]. - (* TODO: Move this *) - Lemma write_lval_uincl (d q:var_i) v (z : psem_t (vtype q)) s3 s4 : - v_var d = v_var q -> - value_uincl v (pto_val z) -> - write_var d v s3 = ok s4 -> - eval_uincl (evm s4).[q] (ok z). - Proof. - rewrite /write_var => -> hu. - t_xrbindP => vm; apply: on_vuP. - + move=> t ht <- <- /=; rewrite Fv.setP_eq => /=. - have [z' []]:= pof_val_uincl hu ht. - by rewrite pof_val_pto_val => -[<-]. - case: is_sboolP z hu => //=. - case: q => -[] qt qn _ /= -> b /= hu /to_bool_undef ?; subst v. - by move=> [<-] <- /=; rewrite Fv.setP_eq. - Qed. Lemma all2_get_pvar args xs : all2 @@ -616,13 +593,12 @@ Section LEMMA. rewrite /check_instr_r /=; case heq : get_fundef => [ fd | //]. t_xrbindP => hces hal hargs hres hxs pre sim. have [vargs' hvargs' hincl]:= check_esP hces sim ok_vargs. - have [||| k [tvm2] [res'] [texec hwf hk get_res res_uincl] ] := - ih ii fd (evm t1) vargs' heq _ (mvp_top_stack pre) (mvp_global_data pre) _ _ hincl. + have [|| k [tvm2] [res'] [texec hk get_res res_uincl] ] := + ih ii fd (evm t1) vargs' heq _ (mvp_top_stack pre) (mvp_global_data pre) _ hincl. + by rewrite (is_align_m hal (mvp_stack_aligned pre)) orbT. - + by case: sim. + elim: (args) (f_params fd) (vargs') hargs hvargs' => [ | e es hrec] [ |y ys] // vs'. move=> /= /andP []; case: e => //= -[] x [] // /eqP hxy hall2. - by rewrite /get_gvar /= hxy; t_xrbindP => ? -> /= ? /hrec -> // <-. + by rewrite /get_gvar /= hxy; t_xrbindP => ? /= /hrec -> // <-. have hget_pvar := all2_get_pvar hargs. have hget_lvar := all2_get_lvar hres. exists {| escs := scs2; emem := m2 ; evm := tvm2 |}. @@ -641,14 +617,14 @@ Section LEMMA. elim: xs vs res' => [ | d ds ih ] [] //. + by move => _ /List_Forall2_inv_l -> [] // d ds _ /=; t_xrbindP. move => v vs _ /List_Forall2_inv_l [v'] [vs'] [->] [vv' vs_vs'] [] // q qs /= hx /=. - t_xrbindP => xd hxd xds hxds ??; subst xd xds => w hq ws hqs ??; subst w ws. + t_xrbindP => xd hxd xds hxds ??; subst xd xds => ws hqs ??; subst v' ws. case: d hxd => // d hxd /andP [] /= /eqP hxq hall2 s3 s4 w ws. move: hx; rewrite /= inE orbX; case/orP; last first. + by move => hx; exact: ih _ _ vs_vs' _ hx hxds hqs hall2 _ ws. case/andP => /eqP hyq /negbTE x_not_in_ys. have <- := vrvsP ws; last by rewrite (vrvs_vars hxds) -Sv.mem_spec sv_of_listE /= x_not_in_ys. - move: hq; apply: on_vuP => // z ok_z ?; subst. - by rewrite ok_z; apply: write_lval_uincl w. + move/write_varP: w vv' => [-> ? /vm_truncate_value_uincl]. + rewrite hxq -hyq Vm.setP_eq; apply: value_uincl_trans. Qed. Lemma Hsyscall : sem_Ind_syscall p Pi_r. @@ -656,7 +632,7 @@ Section LEMMA. move=> s1 scs m s2 o xs es ves vs hes ho hw sz ii I O t1. rewrite /check_instr_r; t_xrbindP => hces hargs hres <- pre sim. have [ves' hves' uves]:= check_esP hces sim hes. - have hes' : mapM (get_var (evm t1)) (syscall_sig o).(scs_vin) = ok ves'. + have hes' : mapM (get_var true (evm t1)) (syscall_sig o).(scs_vin) = ok ves'. + elim: (es) (syscall_sig o).(scs_vin) (ves') hargs hves' => [ | e es' hrec] [ |y ys] // vs'. move=> /= /andP []; case: e => //= -[] x [] // /eqP hxy hall2. by rewrite /get_gvar /= hxy; t_xrbindP => ? -> /= ? /hrec -> // <-. @@ -665,13 +641,12 @@ Section LEMMA. (with_scs (with_mem s1 m) scs) {| escs := scs; emem := m; evm := vm_after_syscall (evm t1) |}. + split => //=. - + move=> z hz; rewrite /vm_after_syscall kill_varsE. - case: Sv_memP. - + by move=> ?; exfalso; apply hz; SvD.fsetdec. - by move=> hz'; apply: (mvm_vmap sim); SvD.fsetdec. - by rewrite /vm_after_syscall; apply: wf_kill_vars; apply: (mvm_wf sim). + move=> z hz; rewrite /vm_after_syscall kill_varsE. + case: Sv_memP. + + by move=> ?; exfalso; apply hz; SvD.fsetdec. + by move=> hz'; apply: (mvm_vmap sim); SvD.fsetdec. have [t2 hw' sim2]: exists2 t2, - write_lvals (p_globs p) {| escs := scs; emem := m; evm := vm_after_syscall (evm t1) |} + write_lvals true (p_globs p) {| escs := scs; emem := m; evm := vm_after_syscall (evm t1) |} (to_lvals (syscall_sig o).(scs_vout)) vs' = ok t2 & match_estate (Sv.diff (Sv.union I syscall_kill) (vrvs (to_lvals (syscall_sig o).(scs_vout)))) s2 t2. + move=> {ho ho' pre hes sim hves' hes'}. @@ -702,7 +677,7 @@ Section LEMMA. Proof. move => scs m ?? fn fd vargs vargs' s0 s1 s2 vres vres' ok_fd ok_vargs /init_stk_stateI -/(_ rip_neq_rsp) [hscs0 vgd_v ok_m' vrsp_v hvmap0] ok_s1 sexec ih ok_vres ok_vres' -> -> - ii fd' tvm1 args' ok_fd' sp_align vrsp_tv vgd_tv hwftvm1 ok_args' ok_args''. + ii fd' tvm1 args' ok_fd' sp_align vrsp_tv vgd_tv ok_args' ok_args''. move: ok_fd'; rewrite ok_fd => /Some_inj ?; subst fd'. case: (checkP ok_p ok_fd) => ok_wrf. rewrite /check_fd; t_xrbindP => D. @@ -758,50 +733,47 @@ Section LEMMA. etransitivity; first by rewrite -Sv.subset_spec; exact: ok_wrf. rewrite /writefun_ra ok_fd. exact: Sv_Subset_union_left. - + by rewrite /t1' /set_RSP /= Fv.setP_eq (write_vars_emem ok_s1). - + subst t1'; rewrite /set_RSP Fv.setP_neq; last by rewrite eq_sym vgd_neq_vrsp. + + by rewrite /t1' /set_RSP /= Vm.setP_eq vm_truncate_val_eq (write_vars_memP ok_s1). + + subst t1'; rewrite /set_RSP Vm.setP_neq; last by rewrite eq_sym vgd_neq_vrsp. rewrite /ra_undef_vm kill_varsE. have := not_written_magic preserved_magic. rewrite /writefun_ra ok_fd /ra_undef. by case: Sv_memP => // h [[] ]; SvD.fsetdec. - rewrite -(write_vars_emem ok_s1) (alloc_stack_top_stack ok_m'). + rewrite -(write_vars_memP ok_s1) (alloc_stack_top_stack ok_m'). exact: do_align_is_align. have sim1 : match_estate ID s1 t1'. - subst t1'; split; - [ by rewrite /=; move: ok_s1; rewrite (write_vars_lvals [::]); apply write_lvals_escs - | by rewrite emem_with_vm (write_vars_emem ok_s1) - | - | by apply/wf_vm_set/wf_kill_vars]. + [ by rewrite /=; move: ok_s1; rewrite (write_vars_lvals _ [::]); apply write_lvals_escs + | by rewrite emem_with_vm (write_vars_memP ok_s1) + | ]. rewrite evm_with_vm /set_RSP => z. case: (z =P vrsp) => [-> _ | /eqP hzrsp hnin]. - + rewrite Fv.setP_eq -(write_vars_eq_except ok_s1) ?vrsp_v //. + + rewrite Vm.setP_eq -(write_vars_eq_ex ok_s1) ?vrsp_v ?vm_truncate_val_eq //. by case: (not_written_magic checked_params). - rewrite Fv.setP_neq; last by rewrite eq_sym. - have huninit : ¬ Sv.In z params → ~~ is_sarr (vtype z) → z ≠ vgd → (evm s1).[z] = undef_error. - + move => h wty zgd; rewrite -(write_vars_eq_except ok_s1) // hvmap0 //; last by apply/eqP. - by rewrite Fv.get0; case: (z) wty => - []. - have hz : eval_uincl (evm s1).[z] tvm1.[z]. + rewrite Vm.setP_neq; last by rewrite eq_sym. + have huninit : ¬ Sv.In z params → ~~ is_sarr (vtype z) → z ≠ vgd → (evm s1).[z] = undef_addr (vtype z). + + move => h wty zgd; rewrite -(write_vars_eq_ex ok_s1) // hvmap0 //; last by apply/eqP. + by rewrite Vm.initP; case: (z) wty => - []. + have hz : value_uincl (evm s1).[z] tvm1.[z]. + case: (Sv_memP z (sv_of_list v_var (f_params fd))) => hinp. + have : List.Forall2 value_uincl vargs args'. + apply: Forall2_trans ok_args''; first by apply: value_uincl_trans. - elim: (f_tyin fd) (vargs') (vargs) ok_vargs => [ | t ts hrec] [ | v' vs'] //= vs. - + by move=> [<-]. - by t_xrbindP => ? /truncate_value_uincl ?? /hrec ? <-; constructor. + apply: mapM2_dc_truncate_value_uincl ok_vargs. move/Sv_memP: hinp; rewrite sv_of_listE /=. elim: (f_params fd) (vargs) (args') (s0) ok_s1 ok_args' => [ | x xs hrec] [ | v vs] vs_ s //=. - t_xrbindP => s' hx hxs v' hget vs' hmap <-; rewrite inE => hin /List_Forall2_inv[] ? H0. + t_xrbindP => s' hx hxs vs' hmap <-; rewrite inE => hin /List_Forall2_inv[] ? H0. case: (@idP (z \in [seq v_var i | i <- xs])) hin => [hin _ | hnin']. + by apply: hrec hxs hmap hin H0. - rewrite orbF => /eqP heq; rewrite -(write_vars_eq_except hxs); last first. + rewrite orbF => /eqP heq; rewrite -(write_vars_eq_ex hxs); last first. + by apply/Sv_memP; rewrite sv_of_listE /=;apply/negP. - move: hget; rewrite /get_var heq; apply: on_vuP => // ? -> ?; subst v'. - apply: (write_lval_uincl _ _ hx) => //. - rewrite -(write_vars_eq_except ok_s1) //. + move/write_varP: hx => [-> _ /vm_truncate_value_uincl htr]. + by rewrite heq Vm.setP_eq; apply: (value_uincl_trans htr). + rewrite -(write_vars_eq_ex ok_s1) //. case: (z =P vgd) => [-> | /eqP hzvgd]; first by rewrite vgd_v vgd_tv. rewrite hvmap0 //. 2-3: by apply/eqP. - rewrite Fv.get0. - case: (tvm1.[z]) (hwftvm1 z) => // [*|[]]//; first by apply eval_uincl_undef. - by case: vtype => //. + rewrite Vm.initP. + apply/compat_value_uincl_undef/Vm.getP. + rewrite /ra_undef_vm kill_varsE; case:Sv_memP; last by []. move: hnin preserved_magic; rewrite /ID /writefun_ra ok_fd -/(ra_undef _ _) -/params Sv.inter_spec => hnin no_magic hin. have {} hnin : ¬ Sv.In z params by intuition. @@ -819,35 +791,32 @@ Section LEMMA. case: sf_save_stack => [ | ra | ofs ] /=; only 1, 3: SvD.fsetdec. by move/Sv.singleton_spec => -> _; t_xrbindP => /eqP ->. rewrite huninit //. - by move: z_not_arr; clear; case: (vtype z). have top_stack2 : top_stack (free_stack (emem s2)) = top_stack m. + have ok_alloc := Memory.alloc_stackP ok_m'. have ok_free := Memory.free_stackP (emem s2). by rewrite {1}/top_stack ok_free.(fss_frames) ok_free.(fss_root) -(sem_stack_stable_sprog sexec).(ss_root) - -(sem_stack_stable_sprog sexec).(ss_frames) -(write_vars_emem ok_s1) ok_alloc.(ass_root) ok_alloc.(ass_frames). + -(sem_stack_stable_sprog sexec).(ss_frames) -(write_vars_memP ok_s1) ok_alloc.(ass_root) ok_alloc.(ass_frames). have [ t2 [ k texec hk ] sim2 ] := ih _ _ _ t1' checked_body pre1 sim1. have [ tres ok_tres res_uincl ] : exists2 tres, - mapM (λ x : var_i, get_var (set_RSP p (free_stack (emem t2)) (evm t2)) x) (f_res fd) = ok tres + mapM (λ x : var_i, get_var false (set_RSP p (free_stack (emem t2)) (evm t2)) x) (f_res fd) = ok tres & List.Forall2 value_uincl vres' tres. - have : forall x, (x \in [seq (v_var i) | i <- f_res fd]) -> ~Sv.In x D. + move=> x hx; have /Sv_memP: Sv.mem x res by rewrite /res sv_of_listE. - by move /Sv.is_empty_spec: hdisj; SvD.fsetdec. - move: (mvm_vmap sim2) ok_vres RSP_not_result (f_tyout fd) vres' ok_vres'. + by move /Sv.is_empty_spec: hdisj; SvD.fsetdec. + move: ok_vres'; rewrite /dc_truncate_val /= => /mapM2_id ?; subst vres'. + move: (mvm_vmap sim2) ok_vres RSP_not_result. rewrite /res sv_of_listE /=; clear. move: (evm s2) (evm t2) (free_stack _) => vm vm' m {s2 t2} hvm. elim: vres (f_res fd) => [ | v vres ih ] [] //=; t_xrbindP => //. - + by move => _ _ [] // _ [<-]; exists [::]. - move => x xs vx hx vs hvxs ??; rewrite inE negb_or => /andP [ hne hnin]. - move=> [] //= ty tys; t_xrbindP => _ w ok_w vres' ok_vres' <- h; subst vx vs. - have {ih} [ | tres -> /= res_uincl ] := ih _ hvxs hnin _ _ ok_vres'. + + by move => _ _ _; exists [::]. + move => x xs vx hvxs <- ?; rewrite inE negb_or => /andP [ hne hnin] h; subst vx. + have {ih} [ | tres -> /= res_uincl ] := ih _ hvxs hnin. + by move=> ? h1; apply h; rewrite inE h1 orbT. - have ex : eval_uincl vm.[x] (set_RSP p m vm').[x]. - + by rewrite /set_RSP Fv.setP_neq //; apply: hvm; apply h; rewrite inE eqxx. - have [ tv -> /= v_uincl ] := get_var_uincl_at ex hx. - exists (tv :: tres); first reflexivity. - by constructor => //; apply: value_uincl_trans (truncate_value_uincl ok_w) v_uincl. + have ex : value_uincl vm.[x] (set_RSP p m vm').[x]. + + by rewrite /set_RSP Vm.setP_neq //; apply: hvm; apply h; rewrite inE eqxx. + by eexists; first reflexivity; constructor. exists (Sv.union k (Sv.union (ra_vm fd.(f_extra) var_tmp) (saved_stack_vm fd))), (set_RSP p (free_stack (emem t2)) (evm t2)), tres; split. @@ -870,37 +839,18 @@ Section LEMMA. + exact: sp_align. + exact: vrsp_tv. + exact: ok_m'. - + exact: ok_args'. - + apply: all2_check_ty_val ok_args''. - elim: (mapM2_Forall3 ok_vargs); first by []. - move => ty v v' tys vs vs' /truncate_val_subtype rec _ /= ->. - by rewrite andbT. + have -> : scs = escs s0 by done. exact: texec. - + etransitivity; last exact: ok_tres. - apply: mapM_ext => // x hx. - rewrite {2}/get_var Fv.setP_neq //. - apply/eqP => K. - move: RSP_not_result. - rewrite /res sv_of_listE => /in_map; apply. - by exists x. - + apply: all2_check_ty_val res_uincl. - elim: (mapM2_Forall3 ok_vres'); first by []. - move => _ v v' tys vs vs' /truncate_val_has_type <- _ /= ->. - by rewrite /check_ty_val subtype_refl. + rewrite /valid_RSP -(sem_not_written texec). - + rewrite /t1' /= Fv.setP_eq. - congr (ok (pword_of_word _)). - rewrite -(mvm_mem sim2). - move: ok_s1; rewrite (write_vars_lvals [::]) => /write_lvals_stack_stable /ss_top_stack ->. - by move/sem_stack_stable_sprog: sexec => /ss_top_stack. + + rewrite /t1' /= Vm.setP_eq vm_truncate_val_eq // -(mvm_mem sim2). + move: ok_s1; rewrite (write_vars_lvals _ [::]) => /write_lvals_stack_stable /ss_top_stack ->. + by move/sem_stack_stable_sprog: sexec => /ss_top_stack ->. move/Sv.subset_spec: ok_wrf; rewrite /write_fd /= => ok_wrf. have [_]:= not_written_magic preserved_magic. by rewrite /vrsp /= /writefun_ra Sv.union_spec; intuition. rewrite (mvm_scs sim2) (mvm_mem sim2); reflexivity. - - by apply wf_vm_set; case: sim2. - move: ok_wrf hk; rewrite /valid_writefun /write_fd /= /writefun_ra ok_fd /is_true Sv.subset_spec. - set s := (X in Sv.union _ X); rewrite -/s; move: s (write_c fd.(f_body)) (wrf fn); clear. (* SvD.fsetdec faster *) + set s := (X in Sv.union _ X); rewrite -/s; move: s (write_c fd.(f_body)) (wrf fn); clear. by SvD.fsetdec. - exact: ok_tres. exact: res_uincl. @@ -939,7 +889,7 @@ Proof. case => fd ok_fd Export. move => /merge_varmaps_callP /(_ dummy_instr_info fd _ _ ok_fd). - case: (checkP ok_p ok_fd) => _ok_wrf. + case: (checkP ok_p ok_fd)=> _ok_wrf. rewrite /check_fd; t_xrbindP => D. rewrite {1 2}Export. set ID := (ID in check_c _ ID _). @@ -954,29 +904,26 @@ Proof. - exact/eqP. - exact: to_save_not_result. - exact: RSP_not_result. - move => vm args' ok_vm ok_args' args_args' vm_rsp vm_gd. - have := H vm args' vm_rsp vm_gd ok_vm ok_args' args_args'. - case => k [] vm2 [] res' [] texec ok_vm2 ok_k ok_res' res_res'. + move => vm args' ok_args' args_args' vm_rsp vm_gd. + have := H vm args' vm_rsp vm_gd ok_args' args_args'. + case => k [] vm2 [] res' [] texec ok_k ok_res' res_res'. case/sem_one_varmap.sem_callE: texec. - rewrite ok_fd => _ m0 [scs1 m1 vm1] k' xa xr /Some_inj <-. - rewrite /ra_valid /ra_undef_vm Export => rax_not_magic' ok_save_stack _ _ ok_m0 ok_xa wt_xa texec ok_xr wt_xr s1_rsp [] ????; subst. - move: ok_xa; rewrite ok_args' => /ok_inj ?; subst xa. - have /ok_inj ? : ok xr = ok res' :> exec values. - { rewrite -ok_xr -ok_res'. - apply: mapM_ext => /= r hr. - rewrite {2}/get_var Fv.setP_neq //; apply/eqP => K. - move: RSP_not_result. - rewrite /results sv_of_listE => /in_map; apply. - by exists r. - } subst xr. - exists m0 k' m1 vm1 res' => //; last first. + rewrite ok_fd => ? m0 [scs1 m1 vm1] k' /Some_inj <-. + rewrite /ra_valid /ra_undef_vm Export => rax_not_magic' ok_save_stack _ _ ok_m0 texec s1_rsp [] ????; subst. + exists m0 k' m1 vm1 res'=> //. + + move/Sv.subset_spec: ok_callee_saved ok_k. + move: (writefun_ra _ _ _ _) => W. + move: (sv_of_list _ _) => C. + move: (Sv.union _ (saved_stack_vm _)) => X. + clear. + SvD.fsetdec. + by move: texec; rewrite /ra_undef /ra_undef_vm_none /ra_vm Export /ra_undef_none. - move/Sv.subset_spec: ok_callee_saved ok_k. - move: (writefun_ra _ _ _ _) => W. - move: (sv_of_list _ _) => C. - move: (Sv.union _ (saved_stack_vm _)) => X. - clear. - SvD.fsetdec. + rewrite -ok_res'. + apply: mapM_ext => /= r hr. + rewrite {2}/get_var Vm.setP_neq //; apply/eqP => K. + move: RSP_not_result. + rewrite /results sv_of_listE => /in_map; apply. + by exists r. Qed. End PROG. diff --git a/proofs/compiler/propagate_inline.v b/proofs/compiler/propagate_inline.v index e8a55210e..a8a086435 100644 --- a/proofs/compiler/propagate_inline.v +++ b/proofs/compiler/propagate_inline.v @@ -18,7 +18,6 @@ Module Import E. End E. - (* -------------------------------------------------------------------------- *) (* ** Data structure used for the analisys *) (* -------------------------------------------------------------------------- *) diff --git a/proofs/compiler/propagate_inline_proof.v b/proofs/compiler/propagate_inline_proof.v index 8bb22d777..de08da2b2 100644 --- a/proofs/compiler/propagate_inline_proof.v +++ b/proofs/compiler/propagate_inline_proof.v @@ -10,26 +10,29 @@ Unset Strict Implicit. Unset Printing Implicit Defensive. Local Open Scope seq_scope. -Local Open Scope vmap_scope. Record h_propagate_inline_params + {wsw : WithSubWord} + {dc:DirectCall} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} {sip : SemInstrParams asm_op syscall_state} := { pip_cf_xsemP : - forall gd s e0 e1 e2 e3 cf v, + forall wdb gd s e0 e1 e2 e3 cf v, let e := PappN (Ocombine_flags cf) [:: e0; e1; e2; e3 ] in let e' := cf_xsem enot eand eor expr.eeq e0 e1 e2 e3 cf in - sem_pexpr gd s e = ok v - -> sem_pexpr gd s e' = ok v; + sem_pexpr wdb gd s e = ok v + -> sem_pexpr wdb gd s e' = ok v; }. Section WITH_PARAMS. Context + {wsw : WithSubWord} + {dc:DirectCall} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} @@ -114,59 +117,59 @@ Proof. Qed. Section Global. -Context (gd: glob_decls). +Context (gd : glob_decls). Section SCFC. -Context (s:estate). +Context (s : estate). -Lemma snotE e b: - sem_pexpr gd s e = ok (Vbool b) -> - sem_pexpr gd s (snot e) = ok (Vbool (~~ b)). +Lemma snotE wdb e b: + sem_pexpr wdb gd s e = ok (Vbool b) -> + sem_pexpr wdb gd s (snot e) = ok (Vbool (~~ b)). Proof. - move=> he; have /snotP : sem_pexpr gd s (Papp1 Onot e) = ok (Vbool (~~b)). + move=> he; have /snotP : sem_pexpr wdb gd s (Papp1 Onot e) = ok (Vbool (~~b)). + by rewrite /= he. by move=> [v] [->] /value_uinclE ->. Qed. -Lemma sbeqE e0 e1 b0 b1 : - sem_pexpr gd s e0 = ok (Vbool b0) -> - sem_pexpr gd s e1 = ok (Vbool b1) -> - sem_pexpr gd s (sbeq e0 e1) = ok (Vbool (b0 == b1)). +Lemma sbeqE wdb e0 e1 b0 b1 : + sem_pexpr wdb gd s e0 = ok (Vbool b0) -> + sem_pexpr wdb gd s e1 = ok (Vbool b1) -> + sem_pexpr wdb gd s (sbeq e0 e1) = ok (Vbool (b0 == b1)). Proof. move=> h0 h1. - have : sem_pexpr gd s (Papp2 Obeq e0 e1) = ok (Vbool (b0 == b1)). + have : sem_pexpr wdb gd s (Papp2 Obeq e0 e1) = ok (Vbool (b0 == b1)). - by rewrite /= h0 h1. clear h0 h1. move=> /sbeqP [v [-> hincl]]. by move: hincl => /value_uinclE ?; subst v. Qed. -Lemma sorE e1 e2 b1 b2 : - sem_pexpr gd s e1 = ok (Vbool b1) -> - sem_pexpr gd s e2 = ok (Vbool b2) -> - sem_pexpr gd s (sor e1 e2) = ok (Vbool (b1 || b2)). -Proof. - move=> h1 h2; have : sem_pexpr gd s (Papp2 Oor e1 e2) = ok (Vbool (b1 || b2)). +Lemma sorE wdb e1 e2 b1 b2 : + sem_pexpr wdb gd s e1 = ok (Vbool b1) -> + sem_pexpr wdb gd s e2 = ok (Vbool b2) -> + sem_pexpr wdb gd s (sor e1 e2) = ok (Vbool (b1 || b2)). +Proof. + move=> h1 h2; have : sem_pexpr wdb gd s (Papp2 Oor e1 e2) = ok (Vbool (b1 || b2)). + by rewrite /= h1 h2. by move=> /sorP [v] [-> /value_uinclE ->]. Qed. -Lemma sandE e1 e2 b1 b2 : - sem_pexpr gd s e1 = ok (Vbool b1) -> - sem_pexpr gd s e2 = ok (Vbool b2) -> - sem_pexpr gd s (sand e1 e2) = ok (Vbool (b1 && b2)). -Proof. - move=> h1 h2; have : sem_pexpr gd s (Papp2 Oand e1 e2) = ok (Vbool (b1 && b2)). +Lemma sandE wdb e1 e2 b1 b2 : + sem_pexpr wdb gd s e1 = ok (Vbool b1) -> + sem_pexpr wdb gd s e2 = ok (Vbool b2) -> + sem_pexpr wdb gd s (sand e1 e2) = ok (Vbool (b1 && b2)). +Proof. + move=> h1 h2; have : sem_pexpr wdb gd s (Papp2 Oand e1 e2) = ok (Vbool (b1 && b2)). + by rewrite /= h1 h2. by move=> /sandP [v] [-> /value_uinclE ->]. Qed. -Lemma fc_esem_ssem e0 e1 e2 e3 fc b : +Lemma fc_esem_ssem wdb e0 e1 e2 e3 fc b : let esem := fc_sem enot eand eor expr.eeq in let ssem := fc_sem snot sand sor sbeq in - sem_pexpr gd s (esem e0 e1 e2 e3 fc) = ok (Vbool b) - -> sem_pexpr gd s (ssem e0 e1 e2 e3 fc) = ok (Vbool b). + sem_pexpr wdb gd s (esem e0 e1 e2 e3 fc) = ok (Vbool b) + -> sem_pexpr wdb gd s (ssem e0 e1 e2 e3 fc) = ok (Vbool b). Proof. rewrite /=. elim: fc b @@ -191,11 +194,11 @@ Proof. [ exact: (sandE h0 h1) | exact: (sorE h0 h1) | exact: (sbeqE h0 h1) ]. Qed. -Lemma cf_esem_ssem e0 e1 e2 e3 cf b : +Lemma cf_esem_ssem wdb e0 e1 e2 e3 cf b : let esem := cf_xsem enot eand eor expr.eeq in let ssem := cf_xsem snot sand sor sbeq in - sem_pexpr gd s (esem e0 e1 e2 e3 cf) = ok (Vbool b) - -> sem_pexpr gd s (ssem e0 e1 e2 e3 cf) = ok (Vbool b). + sem_pexpr wdb gd s (esem e0 e1 e2 e3 cf) = ok (Vbool b) + -> sem_pexpr wdb gd s (ssem e0 e1 e2 e3 cf) = ok (Vbool b). Proof. rewrite /cf_xsem. case: cf_tbl => -[] cfc; last exact: fc_esem_ssem. @@ -207,10 +210,10 @@ Proof. exact: (fc_esem_ssem hv). Qed. -Lemma scfcP c es vs v : - sem_pexprs gd s es = ok vs +Lemma scfcP wdb c es vs v : + sem_pexprs wdb gd s es = ok vs -> sem_opN (Ocombine_flags c) vs = ok v - -> sem_pexpr gd s (scfc c es) = ok v. + -> sem_pexpr wdb gd s (scfc c es) = ok v. Proof. rewrite /scfc. case: es => /= [[<-] | eof es]; first done. @@ -244,27 +247,26 @@ Qed. End SCFC. -Record valid_pi (s : estate) (pi:pimap) := +Record valid_pi (s : estate) (pi : pimap) := { vpi_ok : - forall x c v, - Mvar.get pi x = Some c -> - get_var (evm s) x = ok v -> - exists2 v', sem_pexpr gd s c.(pi_def) = ok v' & value_uincl v v' }. + forall x c, + Mvar.get pi x = Some c -> + exists2 v', sem_pexpr true gd s c.(pi_def) = ok v' & value_uincl (evm s).[x] v' }. Lemma valid_pi_empty s : valid_pi s piempty. -Proof. by constructor => ???; rewrite Mvar.get0. Qed. +Proof. by constructor => ??; rewrite Mvar.get0. Qed. Section Expr. -Context (s:estate) (pi:pimap) (hvalid: valid_pi s pi). +Context (s : estate) (pi : pimap) (hvalid : valid_pi s pi) (wdb : bool). -Let P e : Prop := - forall v, sem_pexpr gd s e = ok v -> - exists2 v', sem_pexpr gd s (pi_e pi e) = ok v' & value_uincl v v'. +Let P e : Prop := + forall v, sem_pexpr wdb gd s e = ok v -> + exists2 v', sem_pexpr wdb gd s (pi_e pi e) = ok v' & value_uincl v v'. -Let Q es : Prop := - forall vs, sem_pexprs gd s es = ok vs -> - exists2 vs', sem_pexprs gd s (pi_es pi es) = ok vs' & List.Forall2 value_uincl vs vs'. +Let Q es : Prop := + forall vs, sem_pexprs wdb gd s es = ok vs -> + exists2 vs', sem_pexprs wdb gd s (pi_es pi es) = ok vs' & List.Forall2 value_uincl vs vs'. Lemma pi_eP_and : (forall e, P e) /\ (forall es, Q es). Proof. @@ -275,7 +277,8 @@ Proof. 1-3: by move=> ?? [<-]; eauto. + move=> x v; case: ifP => h /=; last by eauto. move=> hg; case heq : Mvar.get => [[e' fv m ??] | ]; last by eauto. - by move: hg; rewrite /get_gvar h => /(vpi_ok hvalid heq) /=. + move: hg; rewrite /get_gvar h => /get_varP [-> ??]. + have /= [v' /(sem_pexpr_wdb wdb)??]:= vpi_ok hvalid heq; eexists; eauto. + move=> ?? x e hrec v; apply:on_arr_gvarP; rewrite /on_arr_var => n t ? -> /=. t_xrbindP => i vi /= /hrec [v' -> /= /of_value_uincl_te h] /(h sint) /= -> w hget <-. by rewrite /= hget /=; (eexists; first reflexivity) => /=. @@ -291,7 +294,7 @@ Proof. by rewrite (vuincl_sem_sop2 hu1 hu2 hs); eauto. + move=> o es hrec ?; t_xrbindP => ? /hrec [vs' hs' hu]. case: o => [wz pe | c] /=. - + move=> ho; rewrite -/(sem_pexprs gd _ (pi_es pi es)) hs' /=. + + move=> ho; rewrite -/(sem_pexprs wdb gd _ (pi_es pi es)) hs' /=. by apply: vuincl_sem_opN ho hu. move=> ho; have [v' ho' hu']:= vuincl_sem_opN ho hu. by rewrite -/(pi_es pi es) (scfcP hs' ho'); eauto. @@ -303,29 +306,29 @@ Proof. Qed. Lemma pi_eP e v : - sem_pexpr gd s e = ok v -> - exists2 v', sem_pexpr gd s (pi_e pi e) = ok v' & value_uincl v v'. + sem_pexpr wdb gd s e = ok v -> + exists2 v', sem_pexpr wdb gd s (pi_e pi e) = ok v' & value_uincl v v'. Proof. case: pi_eP_and => h _; apply h. Qed. -Lemma pi_esP es vs : - sem_pexprs gd s es = ok vs -> - exists2 vs', sem_pexprs gd s (pi_es pi es) = ok vs' & +Lemma pi_esP es vs : + sem_pexprs wdb gd s es = ok vs -> + exists2 vs', sem_pexprs wdb gd s (pi_es pi es) = ok vs' & List.Forall2 value_uincl vs vs'. Proof. case: pi_eP_and => _ h; apply h. Qed. -Context (vm:vmap) (hu: vm_uincl (evm s) vm). +Context (vm:Vm.t) (hu: evm s <=1 vm). Lemma pi_eP_uincl e v : - sem_pexpr gd s e = ok v -> - exists2 v', sem_pexpr gd (with_vm s vm) (pi_e pi e) = ok v' & value_uincl v v'. -Proof. + sem_pexpr wdb gd s e = ok v -> + exists2 v', sem_pexpr wdb gd (with_vm s vm) (pi_e pi e) = ok v' & value_uincl v v'. +Proof. move=> /pi_eP [v'] /(sem_pexpr_uincl hu) [v'' ? h2] h1. exists v'' => //; apply: value_uincl_trans h1 h2. Qed. -Lemma pi_esP_uincl es vs : - sem_pexprs gd s es = ok vs -> - exists2 vs', sem_pexprs gd (with_vm s vm) (pi_es pi es) = ok vs' & +Lemma pi_esP_uincl es vs : + sem_pexprs wdb gd s es = ok vs -> + exists2 vs', sem_pexprs wdb gd (with_vm s vm) (pi_es pi es) = ok vs' & List.Forall2 value_uincl vs vs'. Proof. move=> /pi_esP [vs'] /(sem_pexprs_uincl hu) [vs'' ? h2] h1. @@ -334,76 +337,72 @@ Qed. End Expr. -Lemma write_var_valid_pi s s' pi x v : - valid_pi s pi -> - write_var x v s = ok s' -> + +Lemma write_var_valid_pi wdb s s' pi x v : + valid_pi s pi -> + write_var wdb x v s = ok s' -> valid_pi s' (remove pi x) /\ - write_var x v s = ok s'. + write_var wdb x v s = ok s'. Proof. move=> hvalid hw; split => //. - constructor => y c vy; rewrite removeP //; case: eqP => //=. - case: Sv_memP => // hnin /eqP hne h hg. - move: hw; rewrite /write_var /=; t_xrbindP. - move=> vm1 hset1 ?; subst s'; rewrite /= in hg. - move: hg; have /= -> := (get_var_set_var y hset1). - rewrite (negbTE hne) => hg. - have [vy' hs huy]:= vpi_ok hvalid h hg. - exists vy' => //=; rewrite -hs. + constructor => y c; rewrite removeP //; case: eqP => //=. + case: Sv_memP => // hnin /eqP hne h. + move: hw => /write_varP [-> ??] /=; rewrite Vm.setP_neq //. + have [vy' hs huy] := vpi_ok hvalid h. + exists vy' => //=; rewrite -hs. apply eq_on_sem_pexpr => //=. - move=> z hz; have hnez : x.(v_var) != z. - + by apply/eqP => ?; subst z; apply hnin; rewrite h /= pi_fv_ok. - by apply:set_varP hset1 => w hw <-; rewrite Fv.setP_neq. + move=> z hz; rewrite Vm.setP_neq //. + by apply/eqP => ?; subst z; apply hnin; rewrite h /= pi_fv_ok. Qed. Lemma valid_pi_remove_m s pi m : valid_pi s pi -> valid_pi (with_mem s m) (remove_m pi). Proof. - move=> hvalid; constructor; move=> y c vy /=; rewrite remove_mP //. + move=> hvalid; constructor; move=> y c /=; rewrite remove_mP //. case: ifP => //. - move=> hm hy hgy; rewrite hy /= in hm. + move=> hm hy; rewrite hy /= in hm. rewrite pi_m_ok in hm. have /use_memP <- : evm s = evm (with_mem s m) by done. - + by apply (vpi_ok hvalid hy hgy). + + by apply (vpi_ok hvalid hy). by rewrite hm. Qed. -Lemma pi_lvP pi s s' x v : +Lemma pi_lvP wdb pi s s' x v : valid_pi s pi -> - write_lval gd x v s = ok s' -> + write_lval wdb gd x v s = ok s' -> valid_pi s' (pi_lv pi x).1 /\ - write_lval gd (pi_lv pi x).2 v s = ok s'. + write_lval wdb gd (pi_lv pi x).2 v s = ok s'. Proof. move=> hvalid; case: x => /=. - + move=> vi ty /write_noneP [] ->. - by rewrite /write_none => -[ [? ->] | [-> ->]]. + + by move=> vi ty /write_noneP; rewrite /write_none => -[-> -> ->]. + by move=> x; apply write_var_valid_pi. + move=> ws x e; t_xrbindP => px vx gx hpx pe ve he hpe w hw m hwr <-. split; first by apply valid_pi_remove_m. - have /(_ _ _ he) [ve' -> /of_value_uincl_te hu] := pi_eP hvalid. + have /(_ _ _ _ he) [ve' -> /of_value_uincl_te hu] := pi_eP hvalid. have /= -> := hu (sword _) _ hpe. by rewrite gx /= hpx hw /= hwr. + move=> aa ws x e; apply on_arr_varP => n t hty hx. t_xrbindP => i ve he hi w hw t' ht' hwr. rewrite /on_arr_var hx /=. - have /(_ _ _ he) [ve' -> /of_value_uincl_te hu] /= := pi_eP hvalid. + have /(_ _ _ _ he) [ve' -> /of_value_uincl_te hu] /= := pi_eP hvalid. have /= -> := (hu sint _ hi). rewrite hw /= ht' /=. by apply write_var_valid_pi. move=> aa ws len x e; apply on_arr_varP => n t hty hx. t_xrbindP => i ve he hi w hw t' ht' hwr. rewrite /on_arr_var hx /=. - have /(_ _ _ he) [ve' -> /of_value_uincl_te hu] /= := pi_eP hvalid. + have /(_ _ _ _ he) [ve' -> /of_value_uincl_te hu] /= := pi_eP hvalid. have /= -> := (hu sint _ hi). rewrite hw /= ht' /=. by apply write_var_valid_pi. Qed. -Lemma pi_lvsP pi s s' xs vs : +Lemma pi_lvsP wdb pi s s' xs vs : valid_pi s pi -> - write_lvals gd s xs vs = ok s' -> + write_lvals wdb gd s xs vs = ok s' -> valid_pi s' (pi_lvs pi xs).1 /\ - write_lvals gd s (pi_lvs pi xs).2 vs = ok s'. + write_lvals wdb gd s (pi_lvs pi xs).2 vs = ok s'. Proof. elim: xs vs pi s => [ | x xs hrec] [ | v vs] //= pi s hvalid. + by move=> [<-]. @@ -413,28 +412,28 @@ Proof. by rewrite /= hw1. Qed. -Lemma pi_lvP_uincl pi s vm s' x v v': - vm_uincl (evm s) vm -> value_uincl v v' -> +Lemma pi_lvP_uincl wdb pi s vm s' x v v': + evm s <=1 vm -> value_uincl v v' -> valid_pi s pi -> - write_lval gd x v s = ok s' -> + write_lval wdb gd x v s = ok s' -> exists vm', - [/\ vm_uincl (evm s') vm', + [/\ evm s' <=1 vm', valid_pi s' (pi_lv pi x).1 - & write_lval gd (pi_lv pi x).2 v' (with_vm s vm) = ok (with_vm s' vm') ]. + & write_lval wdb gd (pi_lv pi x).2 v' (with_vm s vm) = ok (with_vm s' vm') ]. Proof. move=> hu huv hvalid hw. have [hvalid' hw'] := pi_lvP hvalid hw. by have [vm' hw'' hu']:= write_uincl hu huv hw'; exists vm'. Qed. -Lemma pi_lvsP_uincl pi s vm s' xs vs vs': - vm_uincl (evm s) vm -> List.Forall2 value_uincl vs vs' -> +Lemma pi_lvsP_uincl wdb pi s vm s' xs vs vs': + evm s <=1 vm -> List.Forall2 value_uincl vs vs' -> valid_pi s pi -> - write_lvals gd s xs vs = ok s' -> + write_lvals wdb gd s xs vs = ok s' -> exists vm', - [/\ vm_uincl (evm s') vm', + [/\ evm s' <=1 vm', valid_pi s' (pi_lvs pi xs).1 - & write_lvals gd (with_vm s vm) (pi_lvs pi xs).2 vs' = ok (with_vm s' vm') ]. + & write_lvals wdb gd (with_vm s vm) (pi_lvs pi xs).2 vs' = ok (with_vm s' vm') ]. Proof. move=> hu huv hvalid hw. have [hvalid' hw'] := pi_lvsP hvalid hw. @@ -470,9 +469,9 @@ Section PROOF. Let Pi s1 (i1:instr) s2:= forall pi pi2 vm1, pi_i pi i1 = ok pi2 -> - vm_uincl (evm s1) vm1 -> valid_pi gd s1 pi -> + evm s1 <=1 vm1 -> valid_pi gd s1 pi -> exists vm2, - [/\ vm_uincl (evm s2) vm2, valid_pi gd s2 pi2.1 + [/\ evm s2 <=1 vm2, valid_pi gd s2 pi2.1 & sem_I p2 ev (with_vm s1 vm1) pi2.2 (with_vm s2 vm2)]. Let Pi_r s1 (i1:instr_r) s2 := @@ -481,17 +480,17 @@ Section PROOF. Let Pc s1 (c1:cmd) s2:= forall pi pc2 vm1, pi_c pi_i pi c1 = ok pc2 -> - vm_uincl (evm s1) vm1 -> valid_pi gd s1 pi -> + evm s1 <=1 vm1 -> valid_pi gd s1 pi -> exists vm2, - [/\ vm_uincl (evm s2) vm2, valid_pi gd s2 pc2.1 + [/\ evm s2 <=1 vm2, valid_pi gd s2 pc2.1 & sem p2 ev (with_vm s1 vm1) pc2.2 (with_vm s2 vm2) ]. Let Pfor (i1:var_i) vs s1 c1 s2 := forall pi pc2 vm1, pi_c pi_i (remove pi i1) c1 = ok pc2 -> incl pi pc2.1 -> - vm_uincl (evm s1) vm1 -> valid_pi gd s1 pi -> + evm s1 <=1 vm1 -> valid_pi gd s1 pi -> exists vm2, - [/\ vm_uincl (evm s2) vm2, valid_pi gd s2 pi + [/\ evm s2 <=1 vm2, valid_pi gd s2 pi & sem_for p2 ev i1 vs (with_vm s1 vm1) pc2.2 (with_vm s2 vm2) ]. Let Pfun scs m fn vargs scs' m' vres := @@ -544,17 +543,17 @@ Section PROOF. have [??] : x = x0 /\ pi' = remove pi x0. + by case: (x) heq => // ? [] <- ->. subst x pi'. - constructor => y c vy; rewrite setP; case: andP => [| _]; last by apply (vpi_ok hv'). - move=> [/eqP <- /Sv_memP hnin] [<-] /= hg. - move: hwr; rewrite /= /write_var; t_xrbindP => vm_ /= hset ?; subst s2. - have := sym_eq (get_var_set_var x0 hset); rewrite eqxx hg. - t_xrbindP => vx0 hvx0 ?; subst vy; exists vpe. + constructor => y c; rewrite setP; case: andP => [| _]; last by apply (vpi_ok hv'). + move=> [/eqP <- /Sv_memP hnin] [<-] /=. + move/write_varP: hwr => [? hdb htrv]; subst s2 => /=. + rewrite Vm.setP_eq //. + exists vpe. + rewrite -hvpe; apply eq_on_sem_pexpr => //=. - move=> z hz; have hnz : x0.(v_var) != z by apply/eqP => ?; subst z;apply hnin. - by apply: set_varP hset => ?? <-; rewrite Fv.setP_neq. + move=> z hz; rewrite Vm.setP_neq //. + by apply/eqP => ?; subst z;apply hnin. apply: value_uincl_trans hupe. apply: value_uincl_trans (truncate_value_uincl htr). - by apply value_uincl_pto_val. + apply: vm_truncate_value_uincl htrv. Qed. Local Lemma Hopn : sem_Ind_opn p1 Pi_r. @@ -571,8 +570,8 @@ Section PROOF. Lemma valid_pi_with_scs s pi scs : valid_pi gd s pi -> valid_pi gd (with_scs s scs) pi. Proof. - move=> [] h; constructor => m c v h1 h2. - by have := h _ _ _ h1 h2; rewrite -sem_pexpr_with_scs. + move=> [] h; constructor => m c h1. + by have := h _ _ h1; rewrite -sem_pexpr_with_scs. Qed. Local Lemma Hsyscall : sem_Ind_syscall p1 Pi_r. @@ -589,9 +588,9 @@ Section PROOF. Lemma valid_pi_incl s pi1 pi2 : incl pi1 pi2 -> valid_pi gd s pi2 -> valid_pi gd s pi1. Proof. - move=> hincl hv; constructor => x c v hg hx. + move=> hincl hv; constructor => x c hg. have [c' [hg' heq]] := inclP hincl hg. - have [v' hs hu]:= vpi_ok hv hg' hx. + have [v' hs hu]:= vpi_ok hv hg'. by exists v' => //; rewrite -hs; apply eq_exprP. Qed. @@ -739,11 +738,11 @@ Section PROOF. move=> hget htr hinit hwr _ hc hres hrtr hscs hfin. have [fd2 /=]:= all_checked hget. t_xrbindP => -[pi2 c'] hc_ ? hget2 vargs1 hvargs1; subst fd2. - have [vargs1' {htr} htr hua] := mapM2_truncate_val htr hvargs1. + have [vargs1' {htr} htr hua] := mapM2_dc_truncate_val htr hvargs1. have [{hua hwr} vm1 hwr hu] := write_vars_uincl (vm_uincl_refl _) hua hwr. have [{hc hc_ hu}vm2 [hu' hv' hs]] := hc _ _ _ hc_ hu (valid_pi_empty _ _). have [{hres hu'} vs hvs huvs] := get_vars_uincl hu' hres. - have [{hrtr huvs} vs' hrtr huvs] := mapM2_truncate_val hrtr huvs. + have [{hrtr huvs} vs' hrtr huvs] := mapM2_dc_truncate_val hrtr huvs. exists vs' => //; econstructor; eauto => /=. by case: (s0) hinit => emem evm /=; rewrite eq_p_extra. Qed. diff --git a/proofs/compiler/remove_globals_proof.v b/proofs/compiler/remove_globals_proof.v index e9fa872b8..fde7710f2 100644 --- a/proofs/compiler/remove_globals_proof.v +++ b/proofs/compiler/remove_globals_proof.v @@ -18,20 +18,22 @@ Proof. by move=> h1 h2 g v /h1 /h2. Qed. Module INCL. Section INCL. Context + {wsw : WithSubWord} + {dc:DirectCall} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} {sip : SemInstrParams asm_op syscall_state}. Section INCL_E. - Context (gd1 gd2: glob_decls) (s: estate) (hincl: gd_incl gd1 gd2). + Context (wdb : bool) (gd1 gd2 : glob_decls) (s : estate) (hincl : gd_incl gd1 gd2). Let P e : Prop := - ∀ v, sem_pexpr gd1 s e = ok v → sem_pexpr gd2 s e = ok v. + ∀ v, sem_pexpr wdb gd1 s e = ok v → sem_pexpr wdb gd2 s e = ok v. Let Q es : Prop := - ∀ vs, sem_pexprs gd1 s es = ok vs → sem_pexprs gd2 s es = ok vs. + ∀ vs, sem_pexprs wdb gd1 s es = ok vs → sem_pexprs wdb gd2 s es = ok vs. Lemma gd_incl_gvar (x : gvar) (v : value) : - get_gvar gd1 (evm s) x = ok v → get_gvar gd2 (evm s) x = ok v. + get_gvar wdb gd1 (evm s) x = ok v → get_gvar wdb gd2 (evm s) x = ok v. Proof. by rewrite /get_gvar; case: x => x [] //=; apply: hincl. Qed. Lemma gd_incl_e_es : (∀ e, P e) ∧ (∀ es, Q es). @@ -47,23 +49,23 @@ Module INCL. Section INCL. - by move => sz x e hrec v; t_xrbindP => ?? -> /= -> ?? /hrec -> /= -> ? /= -> <-. - by move=> ? e hrec v; t_xrbindP => ? /hrec -> <-. - by move=> ? e1 hrec1 e2 hrec2 v; t_xrbindP => ? /hrec1 -> ? /= /hrec2 -> <-. - - by move => op es rec v; rewrite -!/(sem_pexprs _ _); t_xrbindP => vs /rec ->. + - by move => op es rec v; rewrite -!/(sem_pexprs _ _ _); t_xrbindP => vs /rec ->. move=> t e1 hrec1 e2 hrec2 e3 hrec3 v. by t_xrbindP => ?? /hrec1 -> /= -> ?? /hrec2 -> /= -> ?? /hrec3 -> /= -> /= <-. Qed. End INCL_E. - Definition gd_incl_e gd1 gd2 s e v h := - (@gd_incl_e_es gd1 gd2 s h).1 e v. + Definition gd_incl_e wdb gd1 gd2 s e v h := + (@gd_incl_e_es wdb gd1 gd2 s h).1 e v. - Definition gd_incl_es gd1 gd2 s es vs h := - (@gd_incl_e_es gd1 gd2 s h).2 es vs. + Definition gd_incl_es wdb gd1 gd2 s es vs h := + (@gd_incl_e_es wdb gd1 gd2 s h).2 es vs. - Lemma gd_incl_wl gd1 gd2 x v (s1 s2:estate) : + Lemma gd_incl_wl wdb gd1 gd2 x v (s1 s2:estate) : gd_incl gd1 gd2 -> - write_lval gd1 x v s1 = ok s2 -> - write_lval gd2 x v s1 = ok s2. + write_lval wdb gd1 x v s1 = ok s2 -> + write_lval wdb gd2 x v s1 = ok s2. Proof. move=> hincl;case: x => //=. + by move=> ws x e;t_xrbindP => ?? -> /= -> ?? /(gd_incl_e hincl) -> /= -> ? -> /= ? -> <-. @@ -73,10 +75,10 @@ Module INCL. Section INCL. by rewrite /write_var; t_xrbindP => ?? /(gd_incl_e hincl) -> /= -> ? -> /= ? -> /= ? -> <-. Qed. - Lemma gd_incl_wls gd1 gd2 xs vs s1 s2 : + Lemma gd_incl_wls wdb gd1 gd2 xs vs s1 s2 : gd_incl gd1 gd2 -> - write_lvals gd1 s1 xs vs = ok s2 -> - write_lvals gd2 s1 xs vs = ok s2. + write_lvals wdb gd1 s1 xs vs = ok s2 -> + write_lvals wdb gd2 s1 xs vs = ok s2. Proof. move=> hincl;elim: xs vs s1 s2 => //= x xs hrec [|v vs] s1 s2 //=. by t_xrbindP => ? /(gd_incl_wl hincl) -> /hrec /= ->. @@ -110,9 +112,9 @@ Module INCL. Section INCL. Proof. move=> ?????;apply: EmkI. Qed. Local Lemma Hasgn : forall s1 s2 (x : lval) (tag : assgn_tag) ty (e : pexpr) v v', - sem_pexpr gd s1 e = ok v -> + sem_pexpr true gd s1 e = ok v -> truncate_val ty v = ok v' -> - write_lval gd x v' s1 = ok s2 -> + write_lval true gd x v' s1 = ok s2 -> Pi_r s1 (Cassgn x tag ty e) s2. Proof. move=> ???????? /(gd_incl_e hincl) h1 h2 /(gd_incl_wl hincl) h3. @@ -135,18 +137,18 @@ Module INCL. Section INCL. Qed. Local Lemma Hif_true : forall (s1 s2 : estate) (e : pexpr) (c1 c2 : cmd), - sem_pexpr gd s1 e = ok (Vbool true) -> + sem_pexpr true gd s1 e = ok (Vbool true) -> sem P1 ev s1 c1 s2 -> Pc s1 c1 s2 -> Pi_r s1 (Cif e c1 c2) s2. Proof. by move=> ????? /(gd_incl_e hincl) h1 ? h2; apply Eif_true. Qed. Local Lemma Hif_false : forall (s1 s2 : estate) (e : pexpr) (c1 c2 : cmd), - sem_pexpr gd s1 e = ok (Vbool false) -> + sem_pexpr true gd s1 e = ok (Vbool false) -> sem P1 ev s1 c2 s2 -> Pc s1 c2 s2 -> Pi_r s1 (Cif e c1 c2) s2. Proof. by move=> ????? /(gd_incl_e hincl) h1 ? h2; apply Eif_false. Qed. Local Lemma Hwhile_true : forall (s1 s2 s3 s4 : estate) a (c : cmd) (e : pexpr) (c' : cmd), sem P1 ev s1 c s2 -> Pc s1 c s2 -> - sem_pexpr gd s2 e = ok (Vbool true) -> + sem_pexpr true gd s2 e = ok (Vbool true) -> sem P1 ev s2 c' s3 -> Pc s2 c' s3 -> sem_i P1 ev s3 (Cwhile a c e c') s4 -> Pi_r s3 (Cwhile a c e c') s4 -> Pi_r s1 (Cwhile a c e c') s4. Proof. @@ -155,7 +157,7 @@ Module INCL. Section INCL. Local Lemma Hwhile_false : forall (s1 s2 : estate) a (c : cmd) (e : pexpr) (c' : cmd), sem P1 ev s1 c s2 -> Pc s1 c s2 -> - sem_pexpr gd s2 e = ok (Vbool false) -> + sem_pexpr true gd s2 e = ok (Vbool false) -> Pi_r s1 (Cwhile a c e c') s2. Proof. move=> ??????? h1 /(gd_incl_e hincl) ?; apply: Ewhile_false; eauto. Qed. @@ -312,6 +314,8 @@ End EXTEND. Import EXTEND. Module RGP. Section PROOFS. Context + {wsw : WithSubWord} + {dc:DirectCall} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} @@ -333,27 +337,26 @@ Module RGP. Section PROOFS. Definition valid (m:venv) (s1 s2:estate) := [/\ s1.(escs) = s2.(escs), s1.(emem) = s2.(emem), - (forall x, ~~is_glob_var x -> get_var (evm s1) x = get_var (evm s2) x), + (forall x, ~~is_glob_var x -> (evm s1).[x] = (evm s2).[x]), (forall x g, Mvar.get m x = Some g -> is_glob_var x) & - (forall x g v, + (forall x g, Mvar.get m x = Some g -> - get_var (evm s1) x = ok v -> - get_global gd g = ok v) ]. + get_global gd g = ok (evm s1).[x]) ]. Section REMOVE_GLOB_E. - Context (m: venv) (ii: instr_info) (s1 s2: estate) (hvalid: valid m s1 s2). + Context (wdb : bool) (m: venv) (ii: instr_info) (s1 s2: estate) (hvalid: valid m s1 s2). Let Pe e : Prop := ∀ e' v, remove_glob_e ii m e = ok e' → - sem_pexpr gd s1 e = ok v → - sem_pexpr gd s2 e' = ok v. + sem_pexpr wdb gd s1 e = ok v → + sem_pexpr wdb gd s2 e' = ok v. Let Pes es : Prop := ∀ es' vs, mapM (remove_glob_e ii m) es = ok es' → - sem_pexprs gd s1 es = ok vs → - sem_pexprs gd s2 es' = ok vs. + sem_pexprs wdb gd s1 es = ok vs → + sem_pexprs wdb gd s2 es' = ok vs. Lemma remove_glob_e_esP : (∀ e, Pe e) ∧ (∀ es, Pes es). Proof. @@ -367,113 +370,94 @@ Module RGP. Section PROOFS. - by move => n _ _ [<-] [<-]. - move => [x []] e' v /=; rewrite /get_gvar /get_var_ /=. + case : ifP => hx. - + case heq: (Mvar.get _ _) => [ g | // ] [<-]. - by move => /(hm3 _ _ _ heq); apply. - by move=> [<-] h; rewrite /= /get_gvar -hm1 // hx. + + case heq: (Mvar.get _ _) => [ g | // ] [<-] /=. + by rewrite /get_gvar /get_var /=; t_xrbindP => hdef <-; apply hm3. + by move=> [<-] h; rewrite /= /get_gvar /get_var -hm1 // hx. by case => [<-] h;rewrite /= /get_gvar /=. - move => aa ws [x []] e he q v; rewrite /get_var_ /=; t_xrbindP => e' ok_e'; last first. + move=> <- /=; apply: on_arr_gvarP; rewrite /on_arr_var /get_gvar /= => n t heq ->. by t_xrbindP => ?? /(he _ _ ok_e') -> /= -> ? /= -> <-. move=> gx; case: ifPn => // hx; last first. + move=> [<-] <-;apply: on_arr_gvarP; rewrite /= /on_arr_var /get_gvar /= => n t heq. - by rewrite -hm1 // => -> /=; t_xrbindP => ?? /(he _ _ ok_e') -> /= -> ? /= -> <-. + by rewrite /get_var -hm1 // => -> /=; t_xrbindP => ?? /(he _ _ ok_e') -> /= -> ? /= -> <-. case heq: (Mvar.get _ _) => [ g | // ] [<-] <-. - apply: on_arr_gvarP; rewrite /= /on_arr_var /get_gvar /= => n t ? /(hm3 _ _ _ heq) -> /=. - by t_xrbindP => ?? /(he _ _ ok_e') -> /= -> ? /= -> <-. + apply: on_arr_gvarP; rewrite /= /on_arr_var /get_gvar /get_var /= => n t ?. + by t_xrbindP => hdef; have:= hm3 _ _ heq => -> -> /= ?? /(he _ _ ok_e') -> /= -> ? /= -> <-. - move => aa ws len [x []] e he q v; rewrite /get_var_ /=; t_xrbindP => e' ok_e'; last first. + move=> <- /=; apply: on_arr_gvarP; rewrite /on_arr_var /get_gvar /= => n t heq ->. by t_xrbindP => ?? /(he _ _ ok_e') -> /= -> ? /= -> <-. move=> gx; case: ifPn => // hx; last first. - + move=> [<-] <-;apply: on_arr_gvarP; rewrite /= /on_arr_var /get_gvar /= => n t heq. + + move=> [<-] <-;apply: on_arr_gvarP; rewrite /= /on_arr_var /get_gvar /get_var /= => n t heq. by rewrite -hm1 // => -> /=; t_xrbindP => ?? /(he _ _ ok_e') -> /= -> ? /= -> <-. case heq: (Mvar.get _ _) => [ g | // ] [<-] <-. - apply: on_arr_gvarP; rewrite /= /on_arr_var /get_gvar /= => n t ? /(hm3 _ _ _ heq) -> /=. - by t_xrbindP => ?? /(he _ _ ok_e') -> /= -> ? /= -> <-. - - move => ??? ih ??; case: ifPn => // hn. - t_xrbindP => ? /ih h <- /= ??; rewrite (hm1 _ hn) => -> /= -> ?? /h -> /= -> ? /=. + apply: on_arr_gvarP; rewrite /= /on_arr_var /get_gvar /get_var /= => n t ?. + by t_xrbindP; have := hm3 _ _ heq => -> ? -> /= ?? /(he _ _ ok_e') -> /= -> ? /= -> <-. + - move => ??? ih ??; case: ifPn => // hn; rewrite /get_gvar /get_var. + t_xrbindP => ? /ih h <- /= ??; rewrite (hm1 _ hn) /get_var => -> -> /= -> ?? /h -> /= -> ? /=. by rewrite hmem => -> <-. - by move=> ?? hrec ??; t_xrbindP => ? /hrec h <- /= ? /h -> /=. - by move=> ?? hrec1 ? hrec2 ??; t_xrbindP=> ? /hrec1 h1 ? /hrec2 h2 <- ? /= /h1 -> ? /h2 ->. - move => ?? ih ??; t_xrbindP => ? /ih{ih} ih <- ? /ih /=. - by rewrite -/(sem_pexprs _ _) => ->. + by rewrite -/(sem_pexprs _ _ _) => ->. move=> ? ? hrec1 ? hrec2 ? hrec3 ??. by t_xrbindP => ? /hrec1 h1 ? /hrec2 h2 ? /hrec3 h3 <- ?? /= /h1 -> /= -> ?? /h2 -> /= -> ?? /h3 -> /= -> <-. Qed. End REMOVE_GLOB_E. - Definition remove_glob_eP m ii s1 s2 e e' v h := - (@remove_glob_e_esP m ii s1 s2 h).1 e e' v. + Definition remove_glob_eP wdb m ii s1 s2 e e' v h := + (@remove_glob_e_esP wdb m ii s1 s2 h).1 e e' v. - Definition remove_glob_esP m ii s1 s2 es es' vs h := - (@remove_glob_e_esP m ii s1 s2 h).2 es es' vs. + Definition remove_glob_esP wdb m ii s1 s2 es es' vs h := + (@remove_glob_e_esP wdb m ii s1 s2 h).2 es es' vs. - Lemma write_var_remove (x:var_i) m s1 s2 v vm : + Lemma write_var_remove wdb (x:var_i) m s1 s2 v s1' : ~~ is_glob_var x -> valid m s1 s2 -> - set_var (evm s1) x v = ok vm -> - exists s2', valid m (with_vm s1 vm) s2' /\ write_var x v s2 = ok s2'. - Proof. - rewrite /write_var /set_var => hglob hval; case:(hval) => hscs hmem hm1 hm2 hm3. - apply: on_vuP. - + move=> ? -> <- /=;eexists;split;last reflexivity. - split => //=. - + move=> y hy; rewrite /get_var /= /on_vu. - case: (v_var x =P y) => [<- | /eqP heq]. - + by rewrite !Fv.setP_eq. - by rewrite !Fv.setP_neq //; apply (hm1 _ hy). - move=> y g v0 hy. - rewrite /get_var /on_vu Fv.setP_neq;first by apply: hm3 hy. - by apply /eqP => ?;subst y; move: hglob; rewrite (hm2 _ _ hy). - move=> ->; case:ifPn => // hx [<-] /=;eexists;split;last reflexivity. - split => //=. - + move=> y hy; rewrite /get_var /= /on_vu. - case: (v_var x =P y) => [<- | /eqP heq]. - + by rewrite !Fv.setP_eq. - by rewrite !Fv.setP_neq //; apply (hm1 _ hy). - move=> y g v0 hy. - rewrite /get_var /on_vu Fv.setP_neq;first by apply: hm3 hy. - by apply /eqP => ?;subst y; move: hglob; rewrite (hm2 _ _ hy). - Qed. - - Lemma remove_glob_lvP m ii s1 s1' s2 lv lv' v : + write_var wdb x v s1 = ok s1' -> + exists s2', valid m s1' s2' /\ write_var wdb x v s2 = ok s2'. + Proof. + move=> hglob hval /write_varP [-> hdb htr]. + rewrite (write_var_truncate hdb htr); eexists; split; eauto. + case: hval => hsc hmem h1 h2 h3; split => //= z hz. + + by rewrite !Vm.setP h1. + move=> hv1; rewrite Vm.setP_neq; first by apply h3. + by apply/eqP => ?; subst z; rewrite (h2 _ _ hv1) in hglob. + Qed. + + Lemma remove_glob_lvP wdb m ii s1 s1' s2 lv lv' v : valid m s1 s2 -> remove_glob_lv ii m lv = ok lv' -> - write_lval gd lv v s1 = ok s1' -> + write_lval wdb gd lv v s1 = ok s1' -> exists s2', - valid m s1' s2' /\ write_lval gd lv' v s2 = ok s2'. + valid m s1' s2' /\ write_lval wdb gd lv' v s2 = ok s2'. Proof. move=> hval; case:(hval) => hscs hmem hm1 hm2 hm3; case:lv => [vi ty|x|ws x e|aa ws x e|aa ws len x e] /=. - + move=> [<-]; apply on_vuP => [?|] hv /=;rewrite /write_none. - + by move=> <-;exists s2;split => //; rewrite hv. - by case : ifPn => // ? [<-]; exists s2; rewrite hv. - + case: ifPn => // hg [<-] /=; rewrite /write_var. - t_xrbindP => ? hset <-. - apply (write_var_remove hg hval hset). + + by move=> [<-] /write_noneP; rewrite /= /write_none => -[-> -> ->]; eauto. + + by case: ifPn => // hg [<-] /=; apply write_var_remove. + case: ifPn => hg //. t_xrbindP => ? /(remove_glob_eP hval) h <- ??. - rewrite hmem (hm1 _ hg) /= => -> /= -> ?? /h -> /= -> ? -> ? /= -> <- /=. + rewrite hmem /= /get_var /get_var (hm1 _ hg) => -> /= -> ?? /h -> /= -> ? -> ? /= -> <- /=. by eexists;split;last reflexivity; split. + case: ifPn => hg //. t_xrbindP => ? /(remove_glob_eP hval) h <-. - apply: on_arr_varP => ?? hty; rewrite (hm1 _ hg) => hget. - rewrite /write_var; t_xrbindP => ?? /h /= -> /= -> ?. - rewrite /on_arr_var /= hget /= => -> ? /= -> ? /= hset <-. - by apply (write_var_remove hg hval hset). + apply: on_arr_varP => ?? hty. + rewrite /= /get_var /on_arr_var /= (hm1 _ hg) => -> /=. + t_xrbindP => ??/h /= -> /= -> ? -> ? /= ->. + by apply write_var_remove. case: ifPn => hg //. t_xrbindP => ? /(remove_glob_eP hval) h <-. - apply: on_arr_varP => ?? hty; rewrite (hm1 _ hg) => hget. - rewrite /write_var; t_xrbindP => ?? /h /= -> /= -> ?. - rewrite /on_arr_var /= hget /= => -> ? /= -> ? /= hset <-. - by apply (write_var_remove hg hval hset). + apply: on_arr_varP => ?? hty; rewrite /= /get_var /on_arr_var (hm1 _ hg) => -> /=. + t_xrbindP => ??/h /= -> /= -> ? -> ? /= ->. + by apply write_var_remove. Qed. - Lemma remove_glob_lvsP m ii s1 s1' s2 lv lv' v : + Lemma remove_glob_lvsP wdb m ii s1 s1' s2 lv lv' v : valid m s1 s2 -> mapM (remove_glob_lv ii m) lv = ok lv' -> - write_lvals gd s1 lv v = ok s1' -> + write_lvals wdb gd s1 lv v = ok s1' -> exists s2', - valid m s1' s2' /\ write_lvals gd s2 lv' v = ok s2'. + valid m s1' s2' /\ write_lvals wdb gd s2 lv' v = ok s2'. Proof. elim: lv lv' v s1 s1' s2 => //=. + by move=> ? []// s1 s1' s2 ? [<-] [<-]; exists s2. @@ -540,32 +524,27 @@ Module RGP. Section PROOFS. Local Lemma Hasgn : sem_Ind_assgn P Pi_r. Proof. move=> s1 s2 x tag ty e v v' he hv hw ii m m' c' /= hrm s1' hval. - move: hrm; t_xrbindP => e' /(remove_glob_eP hval) -/(_ _ he) he'. + move: hrm; t_xrbindP => e' /(remove_glob_eP hval) -/(_ _ _ he) he'. have : (Let lv := remove_globals.remove_glob_lv ii m x in ok (m, [:: MkI ii (Cassgn lv tag ty e')])) = ok (m', c') -> exists s2', valid m' s2 s2' /\ sem P' ev s1' c' s2'. - + t_xrbindP => x' /(remove_glob_lvP hval) -/(_ _ _ hw) [s2' [hs2' hw' ]] <- <-. + + t_xrbindP => x' /(remove_glob_lvP hval) -/(_ _ _ _ hw) [s2' [hs2' hw' ]] <- <-. exists s2';split => //; apply sem_seq1; constructor; econstructor; eauto. case: x hw => //=. move=> xi hxi hdef; case: ifPn => // hglob {hdef}. case: e' he' => // - [] // sz [] //= z [?]; subst v. case: andP => //= -[/eqP ? /eqP htxi];subst ty. move: hv; rewrite /truncate_val /= truncate_word_u /= => -[?]; subst v'. - move: xi htxi hglob hxi. - rewrite /write_var /set_var => -[[xty xn] xii] /= ? hglob; subst xty. - rewrite /pof_val /= sumbool_of_boolET => -[<-]. - t_xrbindP => g hfind <- <-;exists s1'; split; last by constructor. - set x := {| vtype := _ |}. + t_xrbindP => h hfind <- <-; exists s1'; split; last by constructor. + move/write_varP: hxi => [-> hdb htr]. case: hval => hscs hm hm1 hm2 hm3; split => //=. - + move=> y hy; rewrite /get_var /on_vu. - rewrite Fv.setP_neq; first by apply hm1. - by apply /eqP => ?;subst y;move: hy;rewrite hglob. + + move=> y hy; rewrite Vm.setP_neq; first by apply hm1. + by apply/eqP => ?;subst y;move: hy;rewrite hglob. + by move=> y gy;rewrite Mvar.setP; case:eqP => [<- // | ?]; apply hm2. - move=> y gy v;rewrite Mvar.setP;case:eqP => [<- | /eqP hneq]. - + move=> [<-]. rewrite /get_var Fv.setP_eq /= => -[<-]. - by apply: find_globP hfind. - by rewrite /get_var Fv.setP_neq //; apply hm3. + move=> y gy;rewrite Mvar.setP Vm.setP //; case:eqP => [|/eqP hneq]; last by apply hm3. + move=> ?[?]; subst; rewrite (find_globP hfind). + by have /vm_truncate_valE [ws] := htr; rewrite htxi => -[[->] ?->]; rewrite cmp_le_refl. Qed. Local Lemma Hopn : sem_Ind_opn P Pi_r. @@ -608,7 +587,7 @@ Module RGP. Section PROOFS. Proof. move=> hincl [hscs hmem hm1 hm2 hm3];split => //. + by move=> x g /(MinclP hincl) -/hm2. - by move=> x g v /(MinclP hincl); apply hm3. + by move=> x g /(MinclP hincl); apply hm3. Qed. Lemma merge_incl_l m1 m2 : Mincl (merge_env m1 m2) m1. @@ -630,7 +609,7 @@ Module RGP. Section PROOFS. Local Lemma Hif_true : sem_Ind_if_true P ev Pc Pi_r. Proof. move=> s1 s2 e c1 c2 he _ hc ii m m' c' /= hrm s1' hval. - move: hrm; t_xrbindP => e' /(remove_glob_eP hval) -/(_ _ he) he'. + move: hrm; t_xrbindP => e' /(remove_glob_eP hval) -/(_ _ _ he) he'. move=> [m1 c1'] /hc -/(_ _ hval) [s2' [hval' hc1']]. move=> [m2 c2'] h /= <- <-. exists s2'; split. @@ -641,7 +620,7 @@ Module RGP. Section PROOFS. Local Lemma Hif_false : sem_Ind_if_false P ev Pc Pi_r. Proof. move=> s1 s2 e c1 c2 he _ hc ii m m' c' /= hrm s1' hval. - move: hrm; t_xrbindP => e' /(remove_glob_eP hval) -/(_ _ he) he'. + move: hrm; t_xrbindP => e' /(remove_glob_eP hval) -/(_ _ _ he) he'. move=> [m1 c1'] h /= [m2 c2'] /hc -/(_ _ hval) [s2' [hval' hc1']] <- <-. exists s2'; split. + apply: valid_Mincl hval'; apply merge_incl_r. @@ -720,8 +699,8 @@ Module RGP. Section PROOFS. Proof. move=> s1 s2 i d lo hi c vlo vhi hlo hhi _ hfor ii m m' c' /= hrn s1' hval. case : ifPn hrn => // hglob. - t_xrbindP => lo' /(remove_glob_eP hval) -/(_ _ hlo) hlo'. - move=> hi' /(remove_glob_eP hval) -/(_ _ hhi) hhi'. + t_xrbindP => lo' /(remove_glob_eP hval) -/(_ _ _ hlo) hlo'. + move=> hi' /(remove_glob_eP hval) -/(_ _ _ hhi) hhi'. move=> [m2 c2] /= /loopP [m1 [hc h1 h2]] [??];subst m2 c'. have hval': valid m' s1 s1' by apply: valid_Mincl hval. have [s2' [??]]:= hfor hglob _ _ _ hc h1 _ hval'. @@ -737,8 +716,7 @@ Module RGP. Section PROOFS. Local Lemma Hfor_cons : sem_Ind_for_cons P ev Pc Pfor. Proof. move=> s1 s2 s3 s4 xi w ws c hw _ hc _ hfor hglob m m' c' hrm hincl s1' hval. - move: hw; rewrite /write_var; t_xrbindP => vm hvm ?;subst s2. - have [s2' [hs2' ws2']]:= write_var_remove hglob hval hvm. + have [s2' [hs2' ws2']]:= write_var_remove hglob hval hw. have [s3' [hs3' ws3']]:= hc _ _ _ hrm _ hs2'. have hval' := valid_Mincl hincl hs3'. have [s4' [hs4' ws4']]:= hfor hglob _ _ _ hrm hincl _ hval'. @@ -777,10 +755,10 @@ Module RGP. Section PROOFS. have hval: valid (Mvar.empty var) s1 s1 by split. have [s2' [hs2' ws2]] := hc _ _ _ hrm _ hval. subst m2; case: (hs2') => /= hscse hmem hm _ _. - have hres2 : mapM (fun x : var_i => get_var (evm s2') x) (f_res f) = ok vres. + have hres2 : mapM (fun x : var_i => get_var (~~ direct_call) (evm s2') x) (f_res f) = ok vres. + elim: (f_res f) (vres) res1 hres1 hres => //= x xs hrec vres0 res1. - t_xrbindP; case: ifPn => hglob // _ ? /hrec hres1 ? v hx vs /hres1 hxs ?. - by subst res1 vres0; rewrite -hm //= hx /= hxs. + t_xrbindP; case: ifPn => hglob // _ ? /hrec hres1 ? v. + by rewrite /get_var hm // => -> vs /hres1 hxs <-; rewrite /= hxs. subst scs2; econstructor; eauto. Qed. diff --git a/proofs/compiler/slh_lowering_proof.v b/proofs/compiler/slh_lowering_proof.v index f3156ab3a..28917965b 100644 --- a/proofs/compiler/slh_lowering_proof.v +++ b/proofs/compiler/slh_lowering_proof.v @@ -169,16 +169,17 @@ Section CONST_PROP. Lemma sem_pexpr_neg_const_prop {syscall_state : Type} + {wsw: WithSubWord} {ep : EstateParams syscall_state} {spp : SemPexprParams} gd s e b : - sem_pexpr gd s e = ok (Vbool b) -> - sem_pexpr gd s (neg_const_prop e) = ok (Vbool (~~ b)). + sem_pexpr true gd s e = ok (Vbool b) -> + sem_pexpr true gd s (neg_const_prop e) = ok (Vbool (~~ b)). Proof. move=> h. have : - sem_pexpr gd s (enot e) = ok (Vbool (~~ b)). + sem_pexpr true gd s (enot e) = ok (Vbool (~~ b)). - by rewrite /= h. move=> /(const_prop_eP (valid_cpm_empty _)) [v' [? /value_uinclE ?]]. @@ -206,6 +207,7 @@ Section H_SH_PARAMS. Context {asm_op syscall_state : Type} + {wsw: WithSubWord} {ep : EstateParams syscall_state} {spp : SemPexprParams} {asmop : asmOp asm_op}. @@ -215,9 +217,9 @@ Section H_SH_PARAMS. forall s s' gd lvs slho es args res lvs' op' es', lower lvs slho es = Some (lvs', op', es') -> not_misspeculating_args slho args - -> sem_pexprs gd s es = ok args + -> sem_pexprs true gd s es = ok args -> exec_sopn (Oslh slho) args = ok res - -> write_lvals gd s lvs res = ok s' + -> write_lvals true gd s lvs res = ok s' -> sem_sopn gd op' s lvs' es' = ok s'. Record h_sh_params (shparams : sh_params) : Type := @@ -281,19 +283,20 @@ Section WITH_PARAMS. Context {asm_op syscall_state : Type} + {wsw: WithSubWord} {ep : EstateParams syscall_state} {spp : SemPexprParams} {sip : SemInstrParams asm_op syscall_state}. -Definition wf_vars (msf_vars: Sv.t) (vm:vmap) := +Definition wf_vars (msf_vars: Sv.t) (vm:Vm.t) := forall x, Sv.mem x msf_vars - -> [/\ get_var vm x = ok (@Vword msf_size 0%R) + -> [/\ vm.[ x ] = @Vword msf_size 0%R & vtype x = sword msf_size ]. Definition wf_cond (oe : option pexpr) (gd : glob_decls) (s : estate) : Prop := - if oe is Some c then sem_pexpr gd s c = ok (Vbool true) /\ ~~ use_mem c + if oe is Some c then sem_pexpr true gd s c = ok (Vbool true) /\ ~~ use_mem c else true. Definition wf_env (env : Env.t) (gd : glob_decls) (s : estate) := @@ -316,37 +319,37 @@ Proof. + by apply: wf_varsI hwfvars. move: hc hwfcond; rewrite /wf_cond. case: Env.cond => [c0|] //; case: Env.cond => [c1|] // heq. - by rewrite (eq_expr_use_mem heq) (eq_exprP _ _ heq). + by rewrite (eq_expr_use_mem heq) (eq_exprP _ _ _ heq). Qed. Lemma wf_env_empty gd s : wf_env Env.empty gd s. Proof. done. Qed. -Lemma wf_env_initial_write_var gd s s' x : +Lemma wf_env_initial_write_var wdb gd s s' x : vtype (v_var x) = sword msf_size - -> write_var x (@Vword msf_size 0) s = ok s' + -> write_var wdb x (@Vword msf_size 0) s = ok s' -> wf_env (Env.initial (Some (v_var x))) gd s'. Proof. move=> hty hwrite; split => //= _ /SvP.singleton_mem_3 <-. - by rewrite (get_var_write_var_word hty hwrite). + by rewrite (get_write_var_word hty hwrite). Qed. Lemma wf_env_update_cond env cond gd s : wf_env env gd s - -> sem_pexpr gd s cond = ok (Vbool true) + -> sem_pexpr true gd s cond = ok (Vbool true) -> ~~ use_mem cond -> wf_env (Env.update_cond env cond) gd s. Proof. by move=> [hwfvars hwfcond] hsemcond hmem; split. Qed. Lemma wf_cond_restrict s s' gd X cond: - evm s = evm s' [\ X] -> + evm s =[\ X] evm s'-> wf_cond cond gd s -> wf_cond (Env.restrict_cond cond X) gd s'. Proof. move=> heq; case: cond => //= c [hc hu]. case: disjointP => //= hdisj; split => //. - rewrite -hc; apply: eq_on_sem_pexpr_nomem => //. + rewrite -hc; apply: use_memP_eq_on => //. by apply/eq_onS=> y /hdisj hy; apply heq. Qed. @@ -380,17 +383,17 @@ Proof. by eexists. Qed. -Lemma wf_env_after_SLHmove_Lvar env gd s s' vi x : +Lemma wf_env_after_SLHmove_Lvar wdb env gd s s' vi x : let: xi := {| v_var := x; v_info := vi; |} in wf_env env gd s -> vtype x = sword msf_size - -> write_var xi (@Vword msf_size 0) s = ok s' + -> write_var wdb xi (@Vword msf_size 0) s = ok s' -> wf_env (Env.after_SLHmove env (Some x)) gd s'. Proof. move=> [hwfvars hwfcond] hty hwrite; rewrite /Env.after_SLHmove; split => /=. - move=> y /Sv_memP hy; case: (x =P y) => [<- | hxy]. - + split=> //. exact: (get_var_write_var_word _ hwrite). - rewrite (get_var_write_var_word_neq _ hwrite); last done. + + split=> //. exact: (get_write_var_word _ hwrite). + rewrite (write_getP_neq _ hwrite); last by apply /eqP. apply: hwfvars. apply/Sv_memP. SvD.fsetdec. @@ -398,10 +401,10 @@ Proof. exact: (vrvP_var hwrite). Qed. -Lemma wf_env_after_SLHmove env gd s s' ii lv ox : +Lemma wf_env_after_SLHmove wdb env gd s s' ii lv ox : wf_env env gd s -> check_lv_msf ii lv = ok ox - -> write_lval gd lv (@Vword msf_size 0) s = ok s' + -> write_lval wdb gd lv (@Vword msf_size 0) s = ok s' -> wf_env (Env.after_SLHmove env ox) gd s'. Proof. move=> [hwfvars hwfcond]. @@ -416,7 +419,7 @@ Proof. Qed. Lemma wf_vars_diff vm vm' msf X: - vm = vm' [\ X] -> + vm =[\X] vm' -> wf_vars msf vm -> wf_vars (Sv.diff msf X) vm'. Proof. @@ -428,9 +431,9 @@ Qed. (* Reducing this lemma to the [after_assign_vars] case is not so straightforward, since everything is modulo [eq_expr] and [Sv.Equal], so we need to prove several [Proper] instances. *) -Lemma wf_env_after_assign_var env gd s s' x v : +Lemma wf_env_after_assign_var wdb env gd s s' x v : wf_env env gd s - -> write_var (ep := ep) x v s = ok s' + -> write_var wdb (ep := ep) x v s = ok s' -> wf_env (Env.after_assign_var env x) gd s'. Proof. rewrite /Env.after_assign_var => -[hwfvars hwfcond] /vrvP_var heq. @@ -439,9 +442,9 @@ Proof. by apply: wf_vars_diff hwfvars. Qed. -Lemma wf_env_after_assign_vars env gd s s' lvs vs : +Lemma wf_env_after_assign_vars wdb env gd s s' lvs vs : wf_env env gd s - -> write_lvals gd s lvs vs = ok s' + -> write_lvals wdb gd s lvs vs = ok s' -> wf_env (Env.after_assign_vars env (vrvs lvs)) gd s'. Proof. rewrite /Env.after_assign_vars => -[hwfvars hwfcond] /vrvsP hwrite. @@ -449,18 +452,18 @@ Proof. by apply: wf_vars_diff hwfvars. Qed. -Lemma wf_env_after_assign_vars1 env gd s s' lv v : +Lemma wf_env_after_assign_vars1 wdb env gd s s' lv v : wf_env env gd s - -> write_lval gd lv v s = ok s' + -> write_lval wdb gd lv v s = ok s' -> wf_env (Env.after_assign_vars env (vrv lv)) gd s'. Proof. move=> hwf hw. - have := @wf_env_after_assign_vars env gd s s' [::lv] [::v] hwf. + have := @wf_env_after_assign_vars wdb env gd s s' [::lv] [::v] hwf. by rewrite /= hw; apply. Qed. Lemma wf_is_cond env c gd s : - wf_env env gd s -> Env.is_cond env c -> sem_pexpr gd s c = ok (Vbool true). + wf_env env gd s -> Env.is_cond env c -> sem_pexpr true gd s c = ok (Vbool true). Proof. move=> [_ hwf] /orP [/eq_exprP -> //| ]. by case: Env.cond hwf => //= c1 [h _] /eq_exprP ->. @@ -471,6 +474,7 @@ Section CHECK_PROOF. Context {eft : eqType} {pT : progT eft} + {dc: DirectCall} {sCP : semCallParams} (shparams : sh_params) (hshparams : h_sh_params shparams) @@ -490,19 +494,19 @@ Section LOWER_SLHO. (forall s s' ii lvs es args res env env', wf_env env (p_globs p') s -> check_slho ii lvs slho es env = ok env' - -> sem_pexprs (p_globs p') s es = ok args + -> sem_pexprs true (p_globs p') s es = ok args -> exec_sopn (Oslh slho) args = ok res - -> write_lvals (p_globs p') s lvs res = ok s' + -> write_lvals true (p_globs p') s lvs res = ok s' -> not_misspeculating_args slho args /\ wf_env env' (p_globs p') s') (only parsing). - Lemma check_e_msfP env s ii e t: + Lemma check_e_msfP wdb env s ii e t: wf_env env (p_globs p') s -> check_e_msf ii env e = ok t -> - sem_pexpr (p_globs p') s e = ok (@Vword msf_size 0). + sem_pexpr wdb (p_globs p') s e = ok (@Vword msf_size 0). Proof. move=> [hwfvars _]; case: e => //=; t_xrbindP => x /andP [/hwfvars [his _]]. - by rewrite /get_gvar => ->. + by rewrite /get_gvar /get_var his => -> /=; rewrite orbT. Qed. (* [wf_env_cond]: we drop the condition. @@ -526,7 +530,7 @@ Section LOWER_SLHO. check_lv_msf ii (nth (Lnone dummy_var_info sint) lvs 0) = ok ox -> to_word msf_size (@Vword msf_size 0) = ok w -> sopn_sem (Oslh SLHmove) w = ok t -> - write_lvals (p_globs p') s lvs [:: Vword t ] = ok s' -> + write_lvals true (p_globs p') s lvs [:: Vword t ] = ok s' -> P -> P /\ wf_env (Env.after_SLHmove env ox) (p_globs p') s'. Proof. @@ -549,7 +553,7 @@ Section LOWER_SLHO. case: es => //= e1; t_xrbindP => -[] //= e2; t_xrbindP. move=> ? /(wf_is_cond hwf) -> - /(check_e_msfP hwf) -> + /(check_e_msfP _ hwf) -> oz hx <- v1' [?] vs v2' [?] es _ <- ?. case: es => // -[?]; subst v1' v2' v1 v2 => t _ [<-] r hr hsem <- hwrite. exact: (lower_SLHmove_exec_sopn_aux hwf hx hr hsem hwrite). @@ -563,7 +567,7 @@ Section LOWER_SLHO. move=> s s' ii lvs es args res env env'. rewrite /exec_sopn /=. case: args => //; t_xrbindP => v [] //= hwf. - case: es => //= e1; t_xrbindP => es /(check_e_msfP hwf) ->. + case: es => //= e1; t_xrbindP => es /(check_e_msfP _ hwf) ->. case: es => /=; t_xrbindP; last by move=> *; subst. move=> ox hx <- _ <- _ _ <- _ t w hw hsem <- hwrite. exact: (lower_SLHmove_exec_sopn_aux hwf hx hw hsem hwrite). @@ -577,7 +581,7 @@ Section LOWER_SLHO. rewrite /exec_sopn /=; t_xrbindP. case: args => //=; t_xrbindP => v1 [] //=; t_xrbindP => v2 [] //=. case: es => //=; t_xrbindP => e1 [] //= e2; t_xrbindP. - move=> es /(check_e_msfP hwf) -> <- v1' he1 ? _ [<-] vs _ <- ? [] <- ?; subst v1' vs. + move=> es /(check_e_msfP _ hwf) -> <- v1' he1 ? _ [<-] vs _ <- ? [] <- ?; subst v1' vs. move=> t w /to_wordI [ws'[ w' [? hw']]] _ /truncate_wordP [_ ->] [<-] <-. case: lvs => //= lv; t_xrbindP => -[] //= s'' hw [?]; subst s''. split => //. @@ -591,7 +595,7 @@ Section LOWER_SLHO. rewrite /exec_sopn /=; t_xrbindP. case: args => //=; t_xrbindP => v1 [] //=; t_xrbindP => v2 [] //=. case: es => //=; t_xrbindP => e1 [] //= e2; t_xrbindP. - move=> es /(check_e_msfP hwf) -> <- v1' he1 ? _ [<-] vs _ <- ? [] <- ?; subst v1' vs. + move=> es /(check_e_msfP _ hwf) -> <- v1' he1 ? _ [<-] vs _ <- ? [] <- ?; subst v1' vs. move=> t1 t2 ht _ /truncate_wordP [_ ->] [<-] <-. case: lvs => //= lv; t_xrbindP => -[] //= s'' hw [?]; subst s''. split; last by apply: wf_env_after_assign_vars1; eauto. @@ -619,9 +623,9 @@ Section LOWER_SLHO. wf_env env (p_globs p') s -> check_slho ii lvs slho es env = ok env' -> shp_lower shparams lvs slho es = Some (lvs', op', es') - -> sem_pexprs (p_globs p') s es = ok args + -> sem_pexprs true (p_globs p') s es = ok args -> exec_sopn (Oslh slho) args = ok res - -> write_lvals (p_globs p') s lvs res = ok s' + -> write_lvals true (p_globs p') s lvs res = ok s' -> sem_sopn (p_globs p') op' s lvs' es' = ok s' /\ wf_env env' (p_globs p') s'. Proof. @@ -646,17 +650,17 @@ Section LOWER_SLHO. if ty is Slh_msf then v = (@Vword msf_size 0%R) else True. - Lemma check_f_argP s ii e ty env v t: + Lemma check_f_argP wdb s ii e ty env v t: wf_env env (p_globs p') s -> check_f_arg ii env e ty = ok t - -> sem_pexpr (p_globs p') s e = ok v + -> sem_pexpr wdb (p_globs p') s e = ok v -> slh_t_spec v ty. - Proof. by case: ty => //= hwf /(check_e_msfP hwf) -> [->]. Qed. + Proof. by case: ty => //= hwf /(check_e_msfP _ hwf) -> [->]. Qed. - Lemma check_f_argsP s ii env es vs tys t: + Lemma check_f_argsP wdb s ii env es vs tys t: wf_env env (p_globs p') s -> check_f_args ii env es tys = ok t - -> sem_pexprs (p_globs p') s es = ok vs + -> sem_pexprs wdb (p_globs p') s es = ok vs -> List.Forall2 slh_t_spec vs tys. Proof. move=> hwf. @@ -666,11 +670,11 @@ Section LOWER_SLHO. constructor => //; apply: hrec hces hes. Qed. - Lemma check_f_lvP ii env env' lv ty s s' v: + Lemma check_f_lvP wdb ii env env' lv ty s s' v: wf_env env (p_globs p') s -> check_f_lv ii env lv ty = ok env' -> slh_t_spec v ty - -> write_lval (p_globs p') lv v s = ok s' + -> write_lval wdb (p_globs p') lv v s = ok s' -> wf_env env' (p_globs p') s'. Proof. case: ty => /=; t_xrbindP. @@ -679,11 +683,11 @@ Section LOWER_SLHO. exact: (wf_env_after_SLHmove hwf hchk hwrite). Qed. - Lemma check_f_lvsP ii env env' lvs tys s s' vs: + Lemma check_f_lvsP wdb ii env env' lvs tys s s' vs: wf_env env (p_globs p') s -> check_f_lvs ii env lvs tys = ok env' -> List.Forall2 slh_t_spec vs tys - -> write_lvals (p_globs p') s lvs vs = ok s' + -> write_lvals wdb (p_globs p') s lvs vs = ok s' -> wf_env env' (p_globs p') s'. Proof. move=> hwf hc hall. @@ -693,11 +697,11 @@ Section LOWER_SLHO. apply: hrec hcs hws; apply: check_f_lvP hwf hc hv hw. Qed. - Lemma init_envP env env' xs ttys tys vs vs' s s': + Lemma init_envP wdb env env' xs ttys tys vs vs' s s': List.Forall2 slh_t_spec vs' tys -> init_fun_env env xs ttys tys = ok env' - -> mapM2 ErrType truncate_val ttys vs' = ok vs - -> write_vars xs vs s = ok s' + -> mapM2 ErrType dc_truncate_val ttys vs' = ok vs + -> write_vars wdb xs vs s = ok s' -> wf_env env (p_globs p') s -> wf_env env' (p_globs p') s'. Proof. @@ -709,15 +713,16 @@ Section LOWER_SLHO. case: ty hx hv; t_xrbindP. + by move=> <- _; apply: wf_env_after_assign_var hwf hw1. move=> /andP [/eqP hx /eqP ?] /= <- ?; subst t v'. - move: hv'; rewrite /truncate_val /= truncate_word_u /= => -[?]; subst v. + have ? : v = @Vword msf_size 0; last subst v. + + by move: hv'; rewrite /dc_truncate_val /truncate_val /= truncate_word_u /=; case: ifP => _ [<-]. exact: (wf_env_after_SLHmove_Lvar (vi := v_info x) hwf hx hw1). Qed. - Lemma check_resP env xs ttys tys vs vs' s t: + Lemma check_resP wdb env xs ttys tys vs vs' s t: wf_env env (p_globs p') s -> check_res env xs ttys tys = ok t -> - mapM (fun x : var_i => get_var (evm s) x) xs = ok vs -> - mapM2 ErrType truncate_val ttys vs = ok vs' -> + mapM (fun x : var_i => get_var wdb (evm s) x) xs = ok vs -> + mapM2 ErrType dc_truncate_val ttys vs = ok vs' -> List.Forall2 slh_t_spec vs' tys. Proof. move=> hwf; elim: xs ttys tys vs vs' t => [ | x xs hrec] [| t ttys] [ | ty tys] //=; t_xrbindP. @@ -726,8 +731,9 @@ Section LOWER_SLHO. t_xrbindP=> v' hv vs' htr <-. constructor; last by apply: hrec hxs hm htr. case: ty hty hty' => //= h1 /eqP ?; subst t. - case: hwf => /(_ _ h1) []; rewrite hget => -[?]; subst v. - by move: hv; rewrite /truncate_val /= truncate_word_u /= => -[<-]. + case: hwf => /(_ _ h1) [] hx. + move: hget; rewrite /get_var hx /= orbT => -[?] _ _; subst v. + by move: hv; rewrite /dc_truncate_val /= /truncate_val /= truncate_word_u /=; case: ifP => _ [<-]. Qed. End LOWER_SLHO. @@ -786,6 +792,7 @@ Context {eft : eqType} {pT : progT eft} {sCP : semCallParams} + {dc : DirectCall} (shparams : sh_params) (hshparams : h_sh_params shparams) (fun_info : funname -> seq slh_t * seq slh_t) @@ -921,7 +928,7 @@ Proof. case heq : is_protect_ptr => [sz /= |]. + have -> : slho = SLHprotect_ptr sz. + by case: (slho) heq => //= _ [->]. - move=> /=; t_xrbindP => /(check_e_msfP hwf) + <- <-. + move=> /=; t_xrbindP => /(check_e_msfP true hwf) + <- <-. rewrite /exec_sopn /=; t_xrbindP. case: args hsemes => // v1; t_xrbindP => -[] // v2; t_xrbindP => -[] // hsemes. rewrite (mapM_nth (Pconst 0%Z) (Vint 0) (n:= 1) hsemes); last by rewrite (size_mapM hsemes). @@ -1133,7 +1140,6 @@ Proof. by rewrite -sem_pexpr_with_scs -h; apply use_memP. Qed. - Lemma Hproc : sem_Ind_proc p ev Pc Pfun. Proof. move=> scs1 m1 _ _ fn [f_i f_tyi f_p f_b f_tyo f_r f_e] /= vargs vargs' s0 s1 s2 vres vres' diff --git a/proofs/compiler/stack_alloc.v b/proofs/compiler/stack_alloc.v index 1fefa474c..3679e7f0d 100644 --- a/proofs/compiler/stack_alloc.v +++ b/proofs/compiler/stack_alloc.v @@ -10,7 +10,6 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope vmap. Local Open Scope seq_scope. Module Import E. diff --git a/proofs/compiler/stack_alloc_proof.v b/proofs/compiler/stack_alloc_proof.v index 54e4bd865..cdaed1a45 100644 --- a/proofs/compiler/stack_alloc_proof.v +++ b/proofs/compiler/stack_alloc_proof.v @@ -12,7 +12,6 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope vmap. Local Open Scope seq_scope. Local Open Scope Z_scope. @@ -46,6 +45,8 @@ Notation spointer := (sword Uptr) (only parsing). Section WITH_PARAMS. Context + {wsw : WithSubWord} + {dc:DirectCall} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} @@ -193,11 +194,11 @@ Class wf_pmap := { }. (* Registers (not introduced by the compiler) hold the same value in [vm1] and [vm2] *) -Definition eq_vm (vm1 vm2:vmap) := +Definition eq_vm (vm1 vm2:Vm.t) := forall (x:var), Mvar.get pmap.(locals) x = None -> ~ Sv.In x pmap.(vnew) -> - get_var vm1 x = get_var vm2 x. + vm1.[x] = vm2.[x]. (* Well-formedness of a [region]. *) Record wf_region (r : region) := { @@ -284,7 +285,7 @@ Definition check_gvalid rmap x : option (sub_region * ByteSet.t) := Definition wfr_VAL (rmap:region_map) (s1:estate) (s2:estate) := forall x sr bytes v, check_gvalid rmap x = Some (sr, bytes) -> - get_gvar gd s1.(evm) x = ok v -> + get_gvar true gd s1.(evm) x = ok v -> eq_sub_region_val x.(gv).(vtype) s2.(emem) sr bytes v. Definition valid_pk rmap (s2:estate) sr pk := @@ -295,7 +296,7 @@ Definition valid_pk rmap (s2:estate) sr pk := check_stack_ptr rmap s ws z f -> read s2.(emem) (sub_region_addr (sub_region_stkptr s ws z)) Uptr = ok (sub_region_addr sr) | Pregptr p => - get_var s2.(evm) p = ok (Vword (sub_region_addr sr)) + s2.(evm).[p] = Vword (sub_region_addr sr) end. Definition wfr_PTR (rmap:region_map) (s2:estate) := @@ -342,9 +343,9 @@ Class valid_state (rmap : region_map) (m0 : mem) (s1 s2 : estate) := { vs_unchanged : mem_unchanged s1.(emem) m0 s2.(emem); (* stack memory (i.e. valid in the target before the call but not in the source) disjoint from writable slots is unchanged between [m0] and [s2] *) - vs_rip : get_var (evm s2) pmap.(vrip) = ok (Vword rip); + vs_rip : (evm s2).[pmap.(vrip)] = Vword rip; (* [vrip] stores address [rip] *) - vs_rsp : get_var (evm s2) pmap.(vrsp) = ok (Vword rsp); + vs_rsp : (evm s2).[pmap.(vrsp)] = Vword rsp; (* [vrsp] stores address [rsp] *) vs_eq_vm : eq_vm s1.(evm) s2.(evm); (* registers already present in the source program store the same values @@ -788,18 +789,18 @@ Proof. by case: Mvar.get => [_|//] [-> ?]. Qed. -Lemma cast_ptrP gd s e i : - sem_pexpr gd s e >>= to_int = ok i -> - exists2 v, sem_pexpr gd s (cast_ptr e) = ok v & value_uincl (Vword (wrepr Uptr i)) v. +Lemma cast_ptrP wdb gd s e i : + sem_pexpr wdb gd s e >>= to_int = ok i -> + exists2 v, sem_pexpr wdb gd s (cast_ptr e) = ok v & value_uincl (Vword (wrepr Uptr i)) v. Proof. t_xrbindP => v he hi. apply: cast_wP. by rewrite /= he /sem_sop1 /= hi. Qed. -Lemma mk_ofsP aa sz gd s2 ofs e i : - sem_pexpr gd s2 e >>= to_int = ok i -> - sem_pexpr gd s2 (mk_ofs aa sz e ofs) = ok (Vword (wrepr Uptr (i * mk_scale aa sz + ofs)%Z)). +Lemma mk_ofsP wdb aa sz gd s2 ofs e i : + sem_pexpr wdb gd s2 e >>= to_int = ok i -> + sem_pexpr wdb gd s2 (mk_ofs aa sz e ofs) = ok (Vword (wrepr Uptr (i * mk_scale aa sz + ofs)%Z)). Proof. rewrite /mk_ofs; case is_constP => /= [? [->] //| {e} e he] /=. rewrite /sem_sop2 /=. @@ -809,8 +810,8 @@ Proof. by rewrite truncate_word_u /= wrepr_add wrepr_mul GRing.mulrC. Qed. -Lemma mk_ofsiP gd s e i aa sz : - Let x := sem_pexpr gd s e in to_int x = ok i -> +Lemma mk_ofsiP wdb gd s e i aa sz : + Let x := sem_pexpr wdb gd s e in to_int x = ok i -> mk_ofsi aa sz e <> None -> mk_ofsi aa sz e = Some (i * mk_scale aa sz). Proof. by case: e => //= _ [->]. Qed. @@ -822,19 +823,19 @@ Section EXPR. (* If [x] is a register, it is not impacted by the presence of global variables per hypothesis [vs_eq_vm]. *) - Lemma get_var_kindP x v: + Lemma get_var_kindP wdb x v: get_var_kind pmap x = ok None -> ~ Sv.In x.(gv) pmap.(vnew) -> - get_gvar gd (evm s) x = ok v -> - get_gvar [::] (evm s') x = ok v. + get_gvar wdb gd (evm s) x = ok v -> + get_gvar wdb [::] (evm s') x = ok v. Proof. rewrite /get_var_kind; case: ifPn => hglob; first by t_xrbindP. case hgl : get_local => // _ /(vs_eq_vm hgl) heq. - by rewrite !get_gvar_nglob // heq. + by rewrite !get_gvar_nglob // /get_var heq. Qed. - Lemma base_ptrP sc : get_var (evm s') (base_ptr pmap sc) = ok (Vword (wbase_ptr sc)). - Proof. by case: sc => /=; [apply: vs_rsp | apply: vs_rip]. Qed. + Lemma base_ptrP sc : (evm s').[base_ptr pmap sc] = Vword (wbase_ptr sc). + Proof. by case: sc => /=; rewrite (vs_rsp, vs_rip). Qed. Lemma Zland_mod z ws : Z.land z (wsize_size ws - 1) = z mod wsize_size ws. Proof. @@ -942,75 +943,75 @@ Section EXPR. by exists sr, bytes. Qed. - Lemma addr_from_pkP (x:var_i) pk sr xi ofs : + Lemma addr_from_pkP wdb (x:var_i) pk sr xi ofs : wf_local x pk -> valid_pk rmap s' sr pk -> addr_from_pk pmap x pk = ok (xi, ofs) -> exists w, - get_var (evm s') xi >>= to_pointer = ok w /\ + get_var wdb (evm s') xi >>= to_pointer = ok w /\ sub_region_addr sr = (w + wrepr _ ofs)%R. Proof. case: pk => //. + move=> sl ofs' ws z sc hwfpk /= -> [<- <-]. - rewrite /= /get_gvar /= base_ptrP /= truncate_word_u. + rewrite /= /get_gvar /get_var /= base_ptrP /= orbT /= truncate_word_u. eexists; split; first by reflexivity. by rewrite (sub_region_addr_direct hwfpk). move=> p hwfpk /= hpk [<- <-]. - rewrite /= /get_gvar /= hpk /= truncate_word_u. + rewrite /= /get_gvar /get_var /= hpk /= orbT /= truncate_word_u. eexists; split; first by reflexivity. by rewrite wrepr0 GRing.addr0. Qed. (* If [x] is a local variable *) Lemma check_mk_addr_ptr (x:var_i) aa ws xi ei e1 i1 pk sr : - sem_pexpr [::] s' e1 >>= to_int = ok i1 -> + sem_pexpr true [::] s' e1 >>= to_int = ok i1 -> wf_local x pk -> valid_pk rmap s' sr pk -> mk_addr_ptr pmap x aa ws pk e1 = ok (xi, ei) -> ∃ (wx wi: pointer), - [/\ Let x := get_var (evm s') xi in to_pointer x = ok wx, - Let x := sem_pexpr [::] s' ei in to_pointer x = ok wi + [/\ Let x := get_var true (evm s') xi in to_pointer x = ok wx, + Let x := sem_pexpr true [::] s' ei in to_pointer x = ok wi & (sub_region_addr sr + wrepr Uptr (i1 * mk_scale aa ws))%R = (wx + wi)%R]. Proof. move=> he1 hwfpk hpk. rewrite /mk_addr_ptr. t_xrbindP=> -[xi' ofs] haddr <- <-. - move: haddr => /(addr_from_pkP hwfpk hpk) [wx [-> ->]]. + move: haddr => /(addr_from_pkP true hwfpk hpk) [wx [-> ->]]. rewrite (mk_ofsP _ _ _ he1) /= truncate_word_u. eexists _, _; split=> //. by rewrite Z.add_comm wrepr_add GRing.addrA. Qed. - Lemma addr_from_vpkP (x:var_i) vpk sr xi ofs : + Lemma addr_from_vpkP wdb (x:var_i) vpk sr xi ofs : wf_vpk x vpk -> valid_vpk rmap s' x sr vpk -> addr_from_vpk pmap x vpk = ok (xi, ofs) -> exists w, - get_var (evm s') xi >>= to_pointer = ok w /\ + get_var wdb (evm s') xi >>= to_pointer = ok w /\ sub_region_addr sr = (w + wrepr _ ofs)%R. Proof. case: vpk => [[ofs' ws]|pk]. + move=> hwfpk /= -> [<- <-]. - rewrite /= /get_gvar /= vs_rip /= truncate_word_u. + rewrite /= /get_gvar /get_var /= vs_rip /= orbT /= truncate_word_u. eexists; split; first by reflexivity. by rewrite (sub_region_addr_glob hwfpk). by apply addr_from_pkP. Qed. Lemma check_mk_addr (x:var_i) aa ws xi ei e1 i1 vpk sr : - sem_pexpr [::] s' e1 >>= to_int = ok i1 -> + sem_pexpr true [::] s' e1 >>= to_int = ok i1 -> wf_vpk x vpk -> valid_vpk rmap s' x sr vpk -> mk_addr pmap x aa ws vpk e1 = ok (xi, ei) -> ∃ (wx wi : pointer), - [/\ Let x := get_var (evm s') xi in to_pointer x = ok wx, - Let x := sem_pexpr [::] s' ei in to_pointer x = ok wi + [/\ Let x := get_var true (evm s') xi in to_pointer x = ok wx, + Let x := sem_pexpr true [::] s' ei in to_pointer x = ok wi & (sub_region_addr sr + wrepr Uptr (i1 * mk_scale aa ws))%R = (wx + wi)%R]. Proof. move=> he1 hwfpk hpk. rewrite /mk_addr. t_xrbindP=> -[xi' ofs] haddr <- <-. - move: haddr => /(addr_from_vpkP hwfpk hpk) [wx [-> ->]]. + move: haddr => /(addr_from_vpkP true hwfpk hpk) [wx [-> ->]]. rewrite (mk_ofsP _ _ _ he1) /= truncate_word_u. eexists _, _; split=> //. by rewrite Z.add_comm wrepr_add GRing.addrA. @@ -1048,14 +1049,14 @@ Section EXPR. Let X e : Prop := ∀ e' v, alloc_e pmap rmap e = ok e' → - sem_pexpr gd s e = ok v → - sem_pexpr [::] s' e' = ok v. + sem_pexpr true gd s e = ok v → + sem_pexpr true [::] s' e' = ok v. Let Y es : Prop := ∀ es' vs, alloc_es pmap rmap es = ok es' → - sem_pexprs gd s es = ok vs → - sem_pexprs [::] s' es' = ok vs. + sem_pexprs true gd s es = ok vs → + sem_pexprs true [::] s' es' = ok vs. Lemma check_varP (x:var_i) t: check_var pmap x = ok t -> @@ -1064,12 +1065,12 @@ Section EXPR. Lemma get_gvar_word x ws gd vm v : x.(gv).(vtype) = sword ws -> - get_gvar gd vm x = ok v -> + get_gvar true gd vm x = ok v -> exists (ws' : wsize) (w : word ws'), (ws' <= ws)%CMP /\ v = Vword w. Proof. move=> hty hget. - have := type_of_get_gvar hget; rewrite hty => /subtypeE [ws' [hty' hsub]]. - have := type_of_valI v; rewrite hty'; case => [? | [w ?]]; subst. + have := type_of_get_gvar hget; rewrite hty => /compat_type_subtype /subtypeE [ws' [hty' hsub]]. + case/type_of_valI: hty' => [? | [w ?]]; subst. + by have := get_gvar_undef hget erefl. by exists ws', w. Qed. @@ -1101,7 +1102,7 @@ Section EXPR. + by t_xrbindP=> /check_diffP hnnew <-; apply: get_var_kindP. case hty: is_word_type => [ws | //]; move /is_word_typeP in hty. t_xrbindP => hcheck [xi ei] haddr <- hget /=. - have h0: Let x := sem_pexpr [::] s' 0 in to_int x = ok 0 by done. + have h0: Let x := sem_pexpr true [::] s' 0 in to_int x = ok 0 by done. have h1: 0 <= 0 /\ wsize_size ws <= size_slot x.(gv). + by rewrite hty /=; lia. have h1' := ofs_bound_option h1 (fun _ => refl_equal). @@ -1121,7 +1122,7 @@ Section EXPR. + move=> aa sz x e1 he1 e' v he'; apply: on_arr_gvarP => n t hty /= hget. t_xrbindP => i vi /he1{he1}he1 hvi w hw <-. move: he'; t_xrbindP => e1' /he1{he1}he1'. - have h0 : sem_pexpr [::] s' e1' >>= to_int = ok i. + have h0 : sem_pexpr true [::] s' e1' >>= to_int = ok i. + by rewrite he1'. move=> [vpk | ]; last first. + t_xrbindP => h /check_diffP h1 <- /=. @@ -1184,9 +1185,9 @@ Lemma valid_state_set_var rmap m0 s1 s2 x v: Proof. case: s1 s2 => scs1 mem1 vm1 [scs2 mem2 vm2] [/=] hscs hvalid hdisj hincl hincl2 hunch hrip hrsp heqvm hwfr heqmem hglobv htop hget hnin. constructor => //=. - + by rewrite get_var_neq //; assert (h:=rip_in_new); SvD.fsetdec. - + by rewrite get_var_neq //; assert (h:=rsp_in_new); SvD.fsetdec. - + by move=> y hy hnnew; apply get_var_set_eq; apply heqvm. + + by rewrite Vm.setP_neq //; assert (h:=rip_in_new); apply/eqP => ?; subst x; apply hnin. + + by rewrite Vm.setP_neq //; assert (h:=rsp_in_new); apply/eqP => ?; subst x; apply hnin. + + by move=> y hy hnnew; rewrite !Vm.setP heqvm. rewrite /with_vm /=; case: hwfr => hwfsr hval hptr. constructor => //. + move=> y sr bytes vy hy; have ? := get_localn_checkg_diff hget hptr hy. @@ -1194,7 +1195,7 @@ Proof. move=> y mp hy; have [pk [hgety hpk]]:= hptr y mp hy; exists pk; split => //. case: pk hgety hpk => //= yp hyp. assert (h := wfr_new (wf_locals hyp)). - by rewrite get_var_neq //; SvD.fsetdec. + by rewrite Vm.setP_neq //;apply /eqP => /=; SvD.fsetdec. Qed. Lemma eq_sub_region_val_disjoint_zrange sr bytes ty mem1 mem2 v p sz : @@ -1379,13 +1380,6 @@ Proof. by case: eqP => [->|] // _; rewrite get_bytes_clear. Qed. -(* -Definition get_gvar_bytes rv r x := - if is_glob x then - ByteSet.full (interval_of_zone {| z_ofs := 0; z_len := size_slot x.(gv) |}) - else get_var_bytes rv r x.(gv). -*) - Lemma check_gvalid_set_sub_region rmap (x:var_i) sr ofs len rmap2 y sry bytes : wf_sub_region sr x.(vtype) -> set_sub_region rmap x sr ofs len = ok rmap2 -> @@ -1505,23 +1499,23 @@ Lemma wfr_VAL_set_sub_region rmap s1 s2 sr (x:var_i) ofs ty mem2 (rmap2 : region p (wsize_size ws) -> read mem2 p ws = read (emem s2) p ws) -> set_sub_region rmap x sr ofs (size_of ty) = ok rmap2 -> - eq_sub_region_val x.(vtype) mem2 sr (get_var_bytes rmap2 sr.(sr_region) x) v -> - wfr_VAL rmap2 (with_vm s1 (evm s1).[x <- pof_val (vtype x) v]) (with_mem s2 mem2). + truncatable true (vtype x) v -> + eq_sub_region_val x.(vtype) mem2 sr (get_var_bytes rmap2 sr.(sr_region) x) (vm_truncate_val (vtype x) v) -> + wfr_VAL rmap2 (with_vm s1 (evm s1).[x <- v]) (with_mem s2 mem2). Proof. - move=> hwfr hwf hofs hreadeq hset hval y sry bytesy vy. + move=> hwfr hwf hofs hreadeq hset htr hval y sry bytesy vy. move=> /(check_gvalid_set_sub_region hwf hset) []. - + case: x hval {hwf hofs hreadeq hset} => x xii /= hval. + + case: x v htr hval {hwf hofs hreadeq hset} => x xii /= v htr hval. move=> [? ? <- ->]; subst x. have [_ hty] := hval. rewrite get_gvar_eq //. - apply on_vuP => //; rewrite -hty. - by move => ? hof hto; rewrite -hto (pto_val_pof_val hof) hty. + by t_xrbindP => hd <-. move=> [? [bytes [hgvalid ->]]]. rewrite get_gvar_neq => //; move=> /(wfr_val hgvalid). assert (hwfy := check_gvalid_wf wfr_wf hgvalid). have hwf' := sub_region_at_ofs_wf hwf hofs. case: eqP => heqr /=. - + apply (eq_sub_region_val_same_region hwf' hwfy heqr hreadeq). + + by apply (eq_sub_region_val_same_region hwf' hwfy heqr hreadeq). apply: (eq_sub_region_val_distinct_regions hwf' hwfy heqr _ hreadeq). by case /set_sub_regionP : hset. Qed. @@ -1581,10 +1575,11 @@ Lemma valid_state_set_sub_region rmap m0 s1 s2 sr (x:var_i) pk ofs ty mem2 v (rm p (wsize_size ws) -> read mem2 p ws = read (emem s2) p ws) -> set_sub_region rmap x sr ofs (size_of ty) = ok rmap2 -> - eq_sub_region_val x.(vtype) mem2 sr (get_var_bytes rmap2 sr.(sr_region) x) v -> - valid_state rmap2 m0 (with_vm s1 (evm s1).[x <- pof_val x.(vtype) v]) (with_mem s2 mem2). + truncatable true (vtype x) v -> + eq_sub_region_val x.(vtype) mem2 sr (get_var_bytes rmap2 sr.(sr_region) x) (vm_truncate_val (vtype x) v) -> + valid_state rmap2 m0 (with_vm s1 (evm s1).[x <- v]) (with_mem s2 mem2). Proof. - move=> hvs hwf hlx hpk hofs hss hvalideq hreadeq hset heqval. + move=> hvs hwf hlx hpk hofs hss hvalideq hreadeq hset htr heqval. have hwf' := sub_region_at_ofs_wf hwf hofs. case:(hvs) => hscs hvalid hdisj hincl hincl2 hunch hrip hrsp heqvm hwfr heqmem hglobv htop. constructor => //=. @@ -1593,12 +1588,12 @@ Proof. + by move=> ??; rewrite hvalideq; apply hincl2. + case /set_sub_regionP : hset => hwritable _. by apply (mem_unchanged_write_slot hwf' hwritable hreadeq hunch). - + move=> y hget; rewrite get_var_neq; first by apply heqvm. - by rewrite /get_local in hlx; congruence. + + move=> y hget; rewrite Vm.setP_neq /=; first by apply heqvm. + by apply /eqP; rewrite /get_local in hlx; congruence. + case: (hwfr) => hwfsr hval hptr; split. + apply (wfr_WF_set hwfsr hwf). by have [_ ->] := set_sub_regionP hset. - + by apply (wfr_VAL_set_sub_region hwfr hwf hofs hreadeq hset heqval). + + by apply (wfr_VAL_set_sub_region hwfr hwf hofs hreadeq hset htr heqval). by apply (wfr_PTR_set_sub_region hlx hwf hpk hreadeq hofs hset hptr). + by apply (eq_mem_source_write_slot hvs hwf' hreadeq). by rewrite -(ss_top_stack hss). @@ -1662,62 +1657,55 @@ Lemma alloc_lvalP rmap r1 r2 v ty m0 (s1 s2: estate) : alloc_lval pmap rmap r1 ty = ok r2 -> valid_state rmap m0 s1 s2 -> type_of_val v = ty -> - forall s1', write_lval gd r1 v s1 = ok s1' -> - exists s2', write_lval [::] r2.2 v s2 = ok s2' /\ valid_state r2.1 m0 s1' s2'. + forall s1', write_lval true gd r1 v s1 = ok s1' -> + exists s2', write_lval true [::] r2.2 v s2 = ok s2' /\ valid_state r2.1 m0 s1' s2'. Proof. move=> ha hvs ?; subst ty. case: r1 ha => //; rewrite /alloc_lval. (* Lnone *) - + move=> vi ty1 [<-] /= s1' /write_noneP [->] h; exists s2; split => //. - by rewrite /write_none; case: h => [ [? ->]| [-> ->]]. + + by move=> vi ty1 [<-] /= s1' /write_noneP; rewrite /write_none => - [-> -> ->]; exists s2. (* Lvar *) + move=> x. case hlx: get_local => [pk | ]; last first. - + t_xrbindP=> /check_diffP hnnew <- s1' /=. - rewrite /write_var; t_xrbindP => vm1 hvm1 <- /=. - by apply: set_varP hvm1=> [v' hv <- | hb hv <-]; rewrite /write_var /set_var hv /= ?hb /=; - eexists;(split;first by reflexivity); apply valid_state_set_var. + + t_xrbindP=> /check_diffP hnnew <- s1' /= /write_varP [-> hdb htr]. + eexists; split; first by apply: (write_var_truncate hdb htr). + by apply valid_state_set_var. case heq: is_word_type => [ws | //]; move /is_word_typeP : heq => hty. - case htyv: subtype => //; rewrite /= /write_var. - t_xrbindP => -[xi ei] ha sr hsr rmap2 hsetw <- /= s1' vm1' hvm1' ?; subst s1' => /=. - have he1 : sem_pexpr [::] s2 0 >>= to_int = ok 0 by done. + case htyv: subtype => //. + t_xrbindP => -[xi ei] ha sr hsr rmap2 hsetw <- /= s1' /write_varP [-> hdb htr] /=. + have he1 : sem_pexpr true [::] s2 0 >>= to_int = ok 0 by done. have hpk := sub_region_pk_valid rmap s2 hsr. have [wx [wi [-> -> /= <-]]]:= check_mk_addr_ptr hvs he1 (wf_locals hlx) hpk ha. - move: hvm1'; apply set_varP; last by rewrite {1}hty. - move=> {ha}; case: x hty hlx hsr hsetw => -[xty xn] xii /= ->. - set x := {| vtype := sword ws; vname := xn |} => hlx hsr hsetw /= w hto <-. - have [ws' [w' [hle ??]]] := subtype_of_val_to_pword htyv hto; subst w v. - rewrite /= truncate_word_le // {hle} /=. - have hwf := sub_region_pk_wf hsr hlx refl_equal. + have := htr; rewrite {1}hty => /(vm_truncate_val_subtype_word hdb htyv) [w htrw -> /=]. + have hwf := sub_region_pk_wf hsr hlx hty. have hvp: validw (emem s2) (sub_region_addr sr + wrepr _ 0)%R ws. + rewrite wrepr0 GRing.addr0. have [halign _] := set_wordP hwf hsetw. - by apply (validw_sub_region_addr hvs hwf halign). - have /writeV -/(_ (zero_extend ws w')) [mem2 hmem2] := hvp. + by apply: (validw_sub_region_addr hvs) halign; rewrite -hty. + have /writeV -/(_ w) [mem2 hmem2] := hvp. rewrite hmem2 /=; eexists;split;first by reflexivity. (* valid_state update word *) have [_ hset] := set_wordP hwf hsetw. - rewrite -to_pword_u. - have hofs: 0 <= 0 /\ size_of (sword ws) <= wsize_size ws by rewrite /=; lia. + have hofs: 0 <= 0 /\ size_slot x <= size_slot x by lia. have hofs' := ofs_bound_option hofs (fun _ => refl_equal). - apply: (valid_state_set_sub_region hvs hwf hlx hpk hofs' _ _ _ hset (v:=Vword (zero_extend ws w'))). + apply: (valid_state_set_sub_region hvs hwf hlx hpk hofs') => //. + by apply (Memory.write_mem_stable hmem2). + by move=> ??; apply (write_validw_eq hmem2). + move=> p ws''. - rewrite -sub_region_addr_offset. - by apply (writeP_neq hmem2). - split => //. - move=> off hmem w hget. + rewrite -sub_region_addr_offset hty. + by apply: (writeP_neq hmem2). + rewrite {2}hty htrw; split => //. + move=> off hmem ? hget; rewrite {1}hty /= in hofs. have /= hoff := get_val_byte_bound hget. - rewrite (write_read8_sub_region hwf hofs hmem2 hoff) Z.sub_0_r /=. + rewrite (write_read8_sub_region hwf hofs hmem2) /= ?hty // Z.sub_0_r /=. move: (hoff); rewrite -!zify => ->. by rewrite -(get_val_byte_word _ hoff). (* Lmem *) + move=> ws x e1 /=; t_xrbindP => /check_varP hx /check_diffP hnnew e1' /(alloc_eP hvs) he1 <-. move=> s1' xp ? hgx hxp w1 v1 /he1 he1' hv1 w hvw mem1 hmem1 <- /=. - have := get_var_kindP hvs hx hnnew; rewrite /get_gvar /= => /(_ _ hgx) -> /=. + have := get_var_kindP hvs hx hnnew; rewrite /get_gvar /= => /(_ _ _ hgx) -> /=. rewrite he1' hxp /= hv1 /= hvw /=. have hvp1 := write_validw hmem1. have /valid_incl_word hvp2 := hvp1. @@ -1758,49 +1746,45 @@ Proof. (* Laset *) move=> aa ws x e1 /=; t_xrbindP => e1' /(alloc_eP hvs) he1. move=> hr2 s1'; apply on_arr_varP => n t hty hxt. - rewrite /write_var; t_xrbindP => i1 v1 /he1 he1' hi1 w hvw t' htt' vm1 hvm1 ?; subst s1'. + t_xrbindP => i1 v1 /he1 he1' hi1 w hvw t' htt' /write_varP [? hdb htr]; subst s1'. case hlx: get_local hr2 => [pk | ]; last first. + t_xrbindP=> /check_diffP hnnew <-. - have /get_var_kindP -/(_ _ hnnew hxt) : get_var_kind pmap (mk_lvar x) = ok None. + have /get_var_kindP -/(_ _ _ hnnew hxt) : get_var_kind pmap (mk_lvar x) = ok None. + by rewrite /get_var_kind /= hlx. rewrite /get_gvar /= => hxt2. - rewrite he1' /= hi1 hxt2 /= hvw /= htt' /=. - rewrite /write_var; apply: set_varP hvm1=> [v' hv <- | ]; last by rewrite {1} hty. - rewrite /set_var hv /=. - by eexists;(split;first by reflexivity); apply valid_state_set_var. + rewrite he1' /= hi1 hxt2 /= hvw /= htt' /= (write_var_truncate hdb htr) //. + by eexists; split; first reflexivity; apply valid_state_set_var. t_xrbindP => rmap2 /set_arr_wordP [sr [hget hal hset]] [xi ei] ha <- /=. - have {he1} he1 : sem_pexpr [::] s2 e1' >>= to_int = ok i1 by rewrite he1'. + have {he1} he1 : sem_pexpr true [::] s2 e1' >>= to_int = ok i1 by rewrite he1'. have /wfr_ptr [pk' [hlx' hpk]] := hget. have hgvalid := check_gvalid_lvar hget. move: hlx'; rewrite hlx => -[?]; subst pk'. have [wx [wi [-> -> /= <-]]]:= check_mk_addr_ptr hvs he1 (wf_locals hlx) hpk ha. - move: hvm1; apply set_varP; last by rewrite {1}hty. - move=> {ha}; case: x hty hlx hxt hget hset hgvalid => -[xty xn] xii /= ->. - set x := {| vtype := sarr n; vname := xn |} => hlx hxt hget hset hgvalid /= ti <- ?; subst vm1. rewrite hvw /=. have /wfr_wf hwf := hget. have [hge0 hlen haa] := WArray.set_bound htt'. have hvp: validw (emem s2) (sub_region_addr sr + wrepr _ (i1 * mk_scale aa ws))%R ws. - + apply (validw_sub_region_at_ofs _ hwf (conj hge0 hlen)). + + have := validw_sub_region_at_ofs _ hwf; rewrite hty; apply => //. apply is_align_add => //. by rewrite WArray.arr_is_align. have /writeV -/(_ w) [mem2 hmem2] := hvp. rewrite hmem2 /=; eexists;split;first by reflexivity. (* valid_state update array *) have hofs: 0 <= i1 * mk_scale aa ws /\ i1 * mk_scale aa ws + size_of (sword ws) <= size_slot x. - + done. + + by rewrite hty. have hofs' := ofs_bound_option hofs (mk_ofsiP he1). have hvalideq := write_validw_eq hmem2. - apply: (valid_state_set_sub_region hvs hwf hlx hpk hofs' _ hvalideq _ hset (x:={|v_var:=x;v_info:=xii|}) (v:=Varr t')). + apply: (valid_state_set_sub_region hvs hwf hlx hpk hofs' _ hvalideq _ hset htr). + by apply (Memory.write_mem_stable hmem2). + move=> p ws' hdisj. apply (writeP_neq hmem2). apply: disjoint_zrange_incl_l hdisj. by apply: (zbetween_sub_region_at_ofs_option hwf _ (mk_ofsiP he1)). + have /vm_truncate_valE [_ ->]:= htr. split=> //. move=> off hmem w0 hget'. have /= hoff := get_val_byte_bound hget'. - rewrite (write_read8_sub_region hwf hofs hmem2 hoff) /=. + rewrite (write_read8_sub_region hwf hofs hmem2) /= ?hty //. move: hget'; rewrite /= (write_read8 htt') WArray.subE /=. case: ifP => // hle. assert (hval := wfr_val hgvalid hxt). @@ -1819,8 +1803,8 @@ Lemma alloc_lvalsP rmap r1 r2 vs ty m0 (s1 s2: estate) : alloc_lvals pmap rmap r1 ty = ok r2 -> valid_state rmap m0 s1 s2 -> seq.map type_of_val vs = ty -> - forall s1', write_lvals gd s1 r1 vs = ok s1' -> - exists s2', write_lvals [::] s2 r2.2 vs = ok s2' /\ valid_state r2.1 m0 s1' s2'. + forall s1', write_lvals true gd s1 r1 vs = ok s1' -> + exists s2', write_lvals true [::] s2 r2.2 vs = ok s2' /\ valid_state r2.1 m0 s1' s2'. Proof. elim: r1 r2 rmap ty vs s1 s2=> //= [|a l IH] r2 rmap [ | ty tys] // [ | v vs] //. + move=> s1 s2 [<-] Hvalid _ s1' [] <-; by exists s2; split. @@ -1836,8 +1820,8 @@ Hypothesis P'_globs : P'.(p_globs) = [::]. Local Opaque arr_size. -Lemma get_ofs_subP gd s i aa ws x e ofs : - sem_pexpr gd s e >>= to_int = ok i -> +Lemma get_ofs_subP wdb gd s i aa ws x e ofs : + sem_pexpr wdb gd s e >>= to_int = ok i -> get_ofs_sub aa ws x e = ok ofs -> ofs = i * mk_scale aa ws. Proof. @@ -1920,18 +1904,13 @@ Proof. by move: hneq=> /eqP /negPf ->. Qed. -Lemma type_of_get_gvar_array gd vm x n (a : WArray.array n) : - get_gvar gd vm x = ok (Varr a) -> +Lemma type_of_get_gvar_array wdb gd vm x n (a : WArray.array n) : + get_gvar wdb gd vm x = ok (Varr a) -> x.(gv).(vtype) = sarr n. -Proof. - move=> hget. - have hnword: ~ is_sword x.(gv).(vtype). - + by rewrite (subtypeEl (type_of_get_gvar hget)). - by have := type_of_get_gvar_not_word hnword hget. -Qed. +Proof. by move=> /get_gvar_compat; rewrite /compat_val /= orbF => -[_] /compat_typeEl. Qed. -Lemma get_Pvar_sub_bound s1 v e y suby ofs len : - sem_pexpr gd s1 e = ok v -> +Lemma get_Pvar_sub_bound wdb s1 v e y suby ofs len : + sem_pexpr wdb gd s1 e = ok v -> get_Pvar_sub e = ok (y, suby) -> match suby with | Some p => p @@ -1949,12 +1928,12 @@ Proof. t_xrbindP=> n _ hty _ i v' he' hv' _ /WArray.get_sub_bound hbound _ ofs' hofs' <- <- [<- <-]. split=> //. rewrite hty. - have {he' hv'} he' : sem_pexpr gd s1 e' >>= to_int = ok i by rewrite he'. + have {he' hv'} he' : sem_pexpr wdb gd s1 e' >>= to_int = ok i by rewrite he'. by move: hofs' => /(get_ofs_subP he') ->. Qed. -Lemma get_Pvar_subP s1 n (a : WArray.array n) e y ofsy ofs len : - sem_pexpr gd s1 e = ok (Varr a) -> +Lemma get_Pvar_subP wdb s1 n (a : WArray.array n) e y ofsy ofs len : + sem_pexpr wdb gd s1 e = ok (Varr a) -> get_Pvar_sub e = ok (y, ofsy) -> match ofsy with | None => (0%Z, size_slot y.(gv)) @@ -1962,7 +1941,7 @@ Lemma get_Pvar_subP s1 n (a : WArray.array n) e y ofsy ofs len : end = (ofs, len) -> n = Z.to_pos len /\ exists (t : WArray.array (Z.to_pos (size_slot y.(gv)))), - get_gvar gd (evm s1) y = ok (Varr t) /\ + get_gvar wdb gd (evm s1) y = ok (Varr t) /\ (forall i w, read a i U8 = ok w -> read t (ofs + i) U8 = ok w). Proof. case: e => //=. @@ -1998,26 +1977,26 @@ Qed. (* is mk_addr_pexpr a good name ? could be pexpr_addr_from_vpk ? *) -Lemma mk_addr_pexprP rmap m0 s1 s2 (x : var_i) vpk sr e1 ofs : +Lemma mk_addr_pexprP wdb rmap m0 s1 s2 (x : var_i) vpk sr e1 ofs : valid_state rmap m0 s1 s2 -> wf_vpk x vpk -> valid_vpk rmap s2 x sr vpk -> mk_addr_pexpr pmap rmap x vpk = ok (e1, ofs) -> exists w, - sem_pexpr [::] s2 e1 >>= to_pointer = ok w /\ + sem_pexpr wdb [::] s2 e1 >>= to_pointer = ok w /\ sub_region_addr sr = (w + wrepr _ ofs)%R. Proof. move=> hvs hwfpk hpk. rewrite /mk_addr_pexpr. case heq: is_stack_ptr => [[[[[s ws] ofs'] z] f]|]; last first. - + by t_xrbindP=> -[x' ofs'] /(addr_from_vpkP hvs hwfpk hpk) haddr <- <-. + + by t_xrbindP=> -[x' ofs'] /(addr_from_vpkP hvs wdb hwfpk hpk) haddr <- <-. move /is_stack_ptrP in heq; subst vpk. rewrite /= in hpk hwfpk. t_xrbindP=> /hpk hread <- <- /=. rewrite (sub_region_addr_stkptr hwfpk) in hread. rewrite truncate_word_u /= - vs_rsp /= + /get_var vs_rsp /= orbT /= truncate_word_u /= hread /= truncate_word_u. @@ -2054,19 +2033,15 @@ Proof. Qed. Lemma wfr_VAL_set_move rmap s1 s2 x sr v : - eq_sub_region_val x.(vtype) (emem s2) sr (get_var_bytes (set_move rmap x sr) sr.(sr_region) x) v -> + truncatable true (vtype x) v -> + eq_sub_region_val x.(vtype) (emem s2) sr (get_var_bytes (set_move rmap x sr) sr.(sr_region) x) + (vm_truncate_val (vtype x) v) -> wfr_VAL rmap s1 s2 -> - wfr_VAL (set_move rmap x sr) (with_vm s1 (evm s1).[x <- pof_val x.(vtype) v]) s2. + wfr_VAL (set_move rmap x sr) (with_vm s1 (evm s1).[x <- v]) s2. Proof. - move=> heqval hval y sry bytesy vy /check_gvalid_set_move []. - + move=> [? ? <- ->]; subst x. - rewrite get_gvar_eq //. - case: heqval => hread hty'. - apply on_vuP => //; rewrite -hty'. - by move => ? hof hto; rewrite -hto (pto_val_pof_val hof) hty'. - move=> [? hgvalid]. - rewrite get_gvar_neq => //. - by apply hval. + move=> htr heqval hval y sry bytesy vy /check_gvalid_set_move []. + + by move=> [? ? <- ->]; subst x; rewrite get_gvar_eq //; t_xrbindP => hd <-. + by move=> [? hgvalid]; rewrite get_gvar_neq => //; apply hval. Qed. Lemma wfr_PTR_set_move (rmap : region_map) s2 x pk sr : @@ -2092,65 +2067,69 @@ Lemma valid_state_set_move rmap m0 s1 s2 x sr pk v : wf_sub_region sr x.(vtype) -> get_local pmap x = Some pk -> valid_pk rmap.(region_var) s2 sr pk -> - eq_sub_region_val x.(vtype) (emem s2) sr (get_var_bytes (set_move rmap x sr) sr.(sr_region) x) v -> - valid_state (set_move rmap x sr) m0 (with_vm s1 (evm s1).[x <- pof_val x.(vtype) v]) s2. + truncatable true (vtype x) v -> + eq_sub_region_val x.(vtype) (emem s2) sr (get_var_bytes (set_move rmap x sr) sr.(sr_region) x) + (vm_truncate_val (vtype x) v) -> + valid_state (set_move rmap x sr) m0 (with_vm s1 (evm s1).[x <- v]) s2. Proof. - move=> hvs hwf hlx hpk heqval. + move=> hvs hwf hlx hpk htr heqval. case:(hvs) => hscs hvalid hdisj hincl hincl2 hunch hrip hrsp heqvm hwfr heqmem hglobv htop. constructor=> //=. - + move=> y hget; rewrite get_var_neq; first by apply heqvm. - by rewrite /get_local in hlx; congruence. + + move=> y hget; rewrite Vm.setP_neq; first by apply heqvm. + by apply /eqP; rewrite /get_local in hlx; congruence. case: (hwfr) => hwfsr hval hptr; split. + by apply (wfr_WF_set hwfsr hwf). - + by apply (wfr_VAL_set_move heqval hval). + + by apply (wfr_VAL_set_move htr heqval hval). by apply (wfr_PTR_set_move hlx hpk hptr). Qed. -Lemma valid_state_set_move_regptr rmap m0 s1 s2 x sr v p : +Lemma ptr_prop x p (w:word Uptr): + get_local pmap x = Some (Pregptr p) -> + type_of_val (Vword w) = vtype p. +Proof. by move=> /wf_locals /= /wfr_rtype ->. Qed. + +Lemma valid_state_set_move_regptr rmap m0 s1 s2 x sr v p: + type_of_val (Vword (sub_region_addr sr)) = vtype p -> valid_state rmap m0 s1 s2 -> wf_sub_region sr x.(vtype) -> get_local pmap x = Some (Pregptr p) -> - eq_sub_region_val x.(vtype) (emem s2) sr (get_var_bytes (set_move rmap x sr) sr.(sr_region) x) v -> - valid_state (set_move rmap x sr) m0 (with_vm s1 (evm s1).[x <- pof_val x.(vtype) v]) - (with_vm s2 (evm s2).[p <- pof_val p.(vtype) (Vword (sub_region_addr sr))]). -Proof. - move=> hvs hwf hlx heqval. + truncatable true (vtype x) v -> + eq_sub_region_val x.(vtype) (emem s2) sr (get_var_bytes (set_move rmap x sr) sr.(sr_region) x) + (vm_truncate_val (vtype x) v) -> + valid_state (set_move rmap x sr) m0 + (with_vm s1 (evm s1).[x <- v]) + (with_vm s2 (evm s2).[p <- Vword (sub_region_addr sr)]). +Proof. + move=> h hvs hwf hlx heqval htr. have /wf_locals /= hlocal := hlx. case:(hvs) => hscs hvalid hdisj hincl hincl2 hunch hrip hrsp heqvm hwfr heqmem hglobv htop. constructor=> //=. - + rewrite get_var_neq //. + + rewrite Vm.setP_neq //; apply /eqP. by apply hlocal.(wfr_not_vrip). - + rewrite get_var_neq //. + + rewrite Vm.setP_neq //; apply /eqP. by apply hlocal.(wfr_not_vrsp). + move=> y hget hnnew. - rewrite get_var_neq; last by rewrite /get_local in hlx; congruence. - rewrite get_var_neq; last by have := hlocal.(wfr_new); congruence. + rewrite Vm.setP_neq; last by apply/eqP; rewrite /get_local in hlx; congruence. + rewrite Vm.setP_neq; last by apply/eqP; have := hlocal.(wfr_new); congruence. by apply heqvm. case: (hwfr) => hwfsr hval hptr; split. + by apply (wfr_WF_set hwfsr hwf). + move=> y sry bytesy vy. move=> /(check_gvalid_set_move) []. - + move=> [? ? <- ->]; subst x. - rewrite get_gvar_eq //. - case: heqval => hread hty'. - apply on_vuP => //; rewrite -hty'. - by move => ? hof hto; rewrite -hto (pto_val_pof_val hof) hty'. - move=> [? hgvalid]. - rewrite get_gvar_neq => //. - by apply hval. + + by move=> [? ? <- ->]; subst x; rewrite get_gvar_eq //; t_xrbindP => hd <-. + by move=> [? hgvalid]; rewrite get_gvar_neq => //; apply hval. move=> y sry. + have htrp : truncatable true (vtype p) (Vword (sub_region_addr sr)). + + by rewrite -h; apply truncatable_type_of. rewrite Mvar.setP; case: eqP. + move=> <- [<-]. - exists (Pregptr p); split=> //=. - rewrite get_var_eq. - rewrite hlocal.(wfr_rtype). - by rewrite /pof_val to_pword_u. + by exists (Pregptr p); split=> //=; rewrite Vm.setP_eq // (vm_truncate_val_eq h) //. move=> hneq /hptr [pk [hly hpk]]. exists pk; split=> //. case: pk hly hpk => //=. + move=> p2 hly. - rewrite get_var_neq //. - by apply (hlocal.(wfr_distinct) hly hneq). + rewrite Vm.setP_neq //. + by apply/eqP/(hlocal.(wfr_distinct) hly hneq). move=> s ofs ws z f hly. rewrite /check_stack_ptr get_var_bytes_set_move_bytes. case: eqP => [_|//]. @@ -2235,10 +2214,12 @@ Lemma valid_state_set_stack_ptr rmap m0 s1 s2 x s ofs ws z f mem2 sr v : disjoint_range (sub_region_addr (sub_region_stkptr s ws z)) Uptr p ws -> read mem2 p ws = read (emem s2) p ws) -> read mem2 (sub_region_addr (sub_region_stkptr s ws z)) Uptr = ok (sub_region_addr sr) -> - eq_sub_region_val x.(vtype) (emem s2) sr (get_var_bytes (set_move rmap x sr) sr.(sr_region) x) v -> - valid_state (set_stack_ptr (set_move rmap x sr) s ws z f) m0 (with_vm s1 (evm s1).[x <- pof_val x.(vtype) v]) (with_mem s2 mem2). + truncatable true (vtype x) v -> + eq_sub_region_val x.(vtype) (emem s2) sr (get_var_bytes (set_move rmap x sr) sr.(sr_region) x) + (vm_truncate_val (vtype x) v) -> + valid_state (set_stack_ptr (set_move rmap x sr) s ws z f) m0 (with_vm s1 (evm s1).[x <- v]) (with_mem s2 mem2). Proof. - move=> hvs hwf hlx hss hvalideq hreadeq hreadptr heqval. + move=> hvs hwf hlx hss hvalideq hreadeq hreadptr htr heqval. have hreadeq': forall p ws, disjoint_range (sub_region_addr (sub_region_at_ofs (sub_region_stkptr s ws z) (Some 0) (wsize_size Uptr))) Uptr p ws -> read mem2 p ws = read (emem s2) p ws. @@ -2252,14 +2233,14 @@ Proof. + by move=> ??; rewrite hvalideq; apply hincl. + by move=> ??; rewrite hvalideq; apply hincl2. + by apply (mem_unchanged_write_slot hwfs refl_equal hreadeq hunch). - + move=> y hget; rewrite get_var_neq; first by apply heqvm. - by rewrite /get_local in hlx; congruence. + + move=> y hget; rewrite Vm.setP_neq; first by apply heqvm. + by apply/eqP; rewrite /get_local in hlx; congruence. case: (hwfr) => hwfsr hval hptr; split. + by apply (wfr_WF_set hwfsr hwf). + move=> y sry bytesy vy /(check_gvalid_set_stack_ptr hvs (wf_vnew hlx) hlocal.(wfs_new)). move=> {bytesy} [bytesy [hgvalidy ? ->]] hgety. have /(check_gvalid_wf (wfr_WF_set hwfsr hwf _)) -/(_ refl_equal) hwfy := hgvalidy. - assert (heqvaly := wfr_VAL_set_move heqval wfr_val hgvalidy hgety). + assert (heqvaly := wfr_VAL_set_move htr heqval wfr_val hgvalidy hgety). case: eqP => heqr /=. + by apply (eq_sub_region_val_same_region hwfs' hwfy heqr hreadeq' heqvaly). by apply (eq_sub_region_val_distinct_regions hwfs' hwfy heqr refl_equal hreadeq' heqvaly). @@ -2279,34 +2260,30 @@ Qed. Lemma valid_state_set_move_sub rmap m0 s1 s2 x pk v sr : valid_state rmap m0 s1 s2 -> get_local pmap x = Some pk -> + truncatable true (vtype x) v -> (forall srx, Mvar.get rmap.(var_region) x = Some srx -> - eq_sub_region_val x.(vtype) (emem s2) srx (get_var_bytes (set_move_sub rmap x sr) srx.(sr_region) x) v) -> - valid_state (set_move_sub rmap x sr) m0 (with_vm s1 (evm s1).[x <- pof_val x.(vtype) v]) s2. + eq_sub_region_val x.(vtype) (emem s2) srx (get_var_bytes (set_move_sub rmap x sr) srx.(sr_region) x) + (vm_truncate_val (vtype x) v)) -> + valid_state (set_move_sub rmap x sr) m0 (with_vm s1 (evm s1).[x <- v]) s2. Proof. - move=> hvs hlx heqval. + move=> hvs hlx htr heqval. case:(hvs) => hscs hvalid hdisj hincl hincl2 hunch hrip hrsp heqvm hwfr heqmem hglobv htop. constructor => //=. - + move=> y hgety; rewrite get_var_neq; first by apply heqvm. - by rewrite /get_local in hlx; congruence. + + move=> y hgety; rewrite Vm.setP_neq; first by apply heqvm. + by apply/eqP; rewrite /get_local in hlx; congruence. case: (hwfr) => hwfsr hval hptr; split=> //. + move=> y sry bytesy vy. move=> /check_gvalid_set_move_sub []. + move=> [? ? hget ->]; subst x. - case: (heqval _ hget) => hread hty. - rewrite get_gvar_eq //. - apply on_vuP => //; rewrite -hty. - by move => ? hof hto; rewrite -hto (pto_val_pof_val hof) hty. - move=> [? hgvalid]. - rewrite get_gvar_neq => //. - by apply hval. + by case: (heqval _ hget) => hread hty; rewrite get_gvar_eq //; t_xrbindP => ? <-. + by move=> [? hgvalid]; rewrite get_gvar_neq => //; apply hval. move=> y sry. move=> /hptr [pky [hly hpky]]. exists pky; split=> //. case: pky hly hpky => //=. move=> s ofs' ws z f hly heq. rewrite /check_stack_ptr get_var_bytes_set_move_bytes. - case: eqP => // _. - case: eqP => //. + case: eqP => // _; case: eqP => //. have /wf_vnew := hlx. by have /wf_locals /wfs_new := hly; congruence. Qed. @@ -2325,7 +2302,7 @@ Lemma valid_state_set_move_sub_write_lval rmap m0 s1 s2 r x ofsx ofs len n (a : | Some p => p | None => (0, size_slot x) end = (ofs, len) -> - write_lval gd r (Varr a) s1 = ok s1' -> + write_lval true gd r (Varr a) s1 = ok s1' -> get_local pmap x = Some pk -> (forall srx, Mvar.get rmap.(var_region) x = Some srx -> srx = sr) -> let: rmap2 := set_move_sub rmap x (sub_region_at_ofs sr (Some ofs) len) in @@ -2335,31 +2312,23 @@ Proof. move=> hvs. set valid_state := valid_state. (* hack due to typeclass interacting badly *) case: r => //=. - + move=> _ [-> <-] [<- <-]. - rewrite /write_var; t_xrbindP=> vm1'; apply: set_varP; last first. - + by move=> /is_sboolP h1 h2; exfalso; move: h2; rewrite h1. - case: x => -[xty xn] xii; case: xty => //=. - move=> nx ax hax <- <-. - set x := {| vname := xn |} => hlx hget hread. - rewrite -(WArray.castK ax). - apply (valid_state_set_move_sub hvs hlx (v:=Varr ax)). - move=> _ /hget ->. - split=> // off hmem w /(cast_get8 hax) /hread. + + move=> _ [-> <-] [<- <-] /write_varP [-> hdb h] hlx hget hread. + have /vm_truncate_valE [hty heq]:= h. + apply (valid_state_set_move_sub hvs hlx h). + move=> _ /hget ->; rewrite heq. + split=> // off hmem w /= /hread. (* TODO: can we do something nicer than [Z.add_0_r]? *) - rewrite -sub_region_addr_offset wrepr0 GRing.addr0 /= Z.add_0_r. - by apply. + by rewrite -sub_region_addr_offset wrepr0 GRing.addr0 /= Z.add_0_r; apply. t_xrbindP=> aa ws {len}len x' e ofs' hofs ? <- [? <-]; subst x' ofs'. - apply: on_arr_varP. - rewrite /write_var; t_xrbindP=> nx ax htyx hxa i v he hv a2 ha2 a3 ha3 vm1'. - have {he hv} he : sem_pexpr gd s1 e >>= to_int = ok i. + apply: on_arr_varP; t_xrbindP => nx ax htyx hxa i v he hv a2 ha2 a3 ha3 /write_varP [ -> hdb h]. + have /vm_truncate_valE [hty heq]:= h. + have {he hv} he : sem_pexpr true gd s1 e >>= to_int = ok i. + by rewrite he. have {hofs} -> := get_ofs_subP he hofs. - apply: set_varP; last by rewrite {1}htyx. - case: x htyx hxa => -[_ xn] xii /= ->. - set x := {| vname := xn |} => hxa /= _ <- <- <- hlx hget hread. - apply (valid_state_set_move_sub hvs hlx (v := Varr a3)). - move=> srx /dup[] /hget{hget} ? hget; subst srx. + move=> hlx hget hread. + apply (valid_state_set_move_sub hvs hlx h). + move=> srx /dup[] /hget{hget} ? hget; subst srx; rewrite heq. split=> // off hmem w /=. rewrite (WArray.set_sub_get8 ha3) /=. case: ifPn => [_|]. @@ -2370,7 +2339,7 @@ Proof. rewrite wrepr_add GRing.addrA (sub_region_addr_offset (arr_size ws len)) Z.add_assoc. by apply hread. rewrite !zify => hbound. - have hgvalid := check_gvalid_lvar (x:={|v_var := x; v_info := xii|}) hget. + have hgvalid := check_gvalid_lvar (x:=x) hget. case: (wfr_val hgvalid hxa) => hread' _. apply hread'. move: hmem. @@ -2387,15 +2356,16 @@ Record h_stack_alloc_params (saparams : stack_alloc_params) := mov_ofsP : forall (P' : sprog) s1 e i x tag ofs w vpk s2 ins, p_globs P' = [::] - -> (Let i' := sem_pexpr [::] s1 e in to_pointer i') = ok i + -> (Let i' := sem_pexpr true [::] s1 e in to_pointer i') = ok i -> sap_mov_ofs saparams x tag vpk e ofs = Some ins - -> write_lval [::] x (Vword (i + wrepr Uptr ofs)) s1 = ok s2 + -> write_lval true [::] x (Vword (i + wrepr Uptr ofs)) s1 = ok s2 -> sem_i P' w s1 ins s2; (* specification of sap_immediate *) sap_immediateP : forall (P' : sprog) w s (x: var_i) z, vtype x = sword Uptr -> - sem_i P' w s (sap_immediate saparams x z) (with_vm s (evm s).[x <- pof_val x.(vtype) (Vword (wrepr Uptr z))]); + sem_i P' w s (sap_immediate saparams x z) + (with_vm s (evm s).[x <- Vword (wrepr Uptr z)]); }. Context @@ -2408,9 +2378,9 @@ Context Lemma alloc_array_moveP m0 s1 s2 s1' rmap1 rmap2 r tag e v v' n i2 : valid_state rmap1 m0 s1 s2 -> - sem_pexpr gd s1 e = ok v -> + sem_pexpr true gd s1 e = ok v -> truncate_val (sarr n) v = ok v' -> - write_lval gd r v' s1 = ok s1' -> + write_lval true gd r v' s1 = ok s1' -> alloc_array_move saparams pmap rmap1 r tag e = ok (rmap2, i2) → ∃ s2' : estate, sem_i P' rip s2 i2 s2' ∧ valid_state rmap2 m0 s1' s2'. Proof. @@ -2437,7 +2407,7 @@ Proof. have hpky: valid_vpk rmap1 s2 y.(gv) sry vpky. + have /wfr_gptr := hgvalidy. by rewrite hkindy => -[_ [[]] <-]. - move=> [e1 ofs2] /(mk_addr_pexprP _ hwfpky hpky) [w [he1 haddr]] ? <- <- ?; subst sry' ofs2'. + move=> [e1 ofs2] /(mk_addr_pexprP true _ hwfpky hpky) [w [he1 haddr]] ? <- <- ?; subst sry' ofs2'. have [? [ay [hgety hay]]] := get_Pvar_subP he hgete hofsy. subst n. have hread: forall bytes, @@ -2455,46 +2425,41 @@ Proof. by apply zbetween_zone_refl. case: r hgetr hw => //. - + move=> _ [-> <-]. - rewrite /write_lval /write_var; t_xrbindP=> vm1'; apply: set_varP; last first. - + by move=> /is_sboolP h1 h2; exfalso; move: h2; rewrite h1. - case: x => -[xty xn] xii; case: xty => //=. - move=> nx ax hax <- <-. - set x := {| vname := xn |}. + + move=> _ [-> <-] /write_varP [ -> hdb h]. + have /vm_truncate_valE [hty htreq]:= h. case hlx: (get_local pmap x) => [pk|//]. have /wf_locals hlocal := hlx. have heqval: forall bytes, eq_sub_region_val x.(vtype) (emem s2) (sub_region_at_ofs sry (Some ofs) len) - bytes (Varr ax). + bytes (Varr a'). + move=> bytes. by split=> // off /hread{hread}hread w' /(cast_get8 hax) /hread. have hwf: wf_sub_region (sub_region_at_ofs sry (Some ofs) len) x.(vtype). - + apply: (wf_sub_region_subtype _ hwfy'). - by apply /eqP; rewrite -(WArray.cast_len hax). - - rewrite -(WArray.castK ax). + + by apply: (wf_sub_region_subtype _ hwfy'); rewrite hty. case: pk hlx hlocal. + t_xrbindP=> s ofs' ws z sc hlx hlocal /eqP heqsub <- <-. exists s2; split; first by constructor. (* valid_state update *) - by apply: (valid_state_set_move hvs hwf hlx _ (heqval _)). - + move=> p hlx hlocal. - case Hmov_ofs: (sap_mov_ofs saparams) => [ins|]; - last done. + by have := (valid_state_set_move hvs hwf hlx _ h); apply => //; rewrite htreq. + + move=> p hlx hlocal /=. + case Hmov_ofs: (sap_mov_ofs saparams) => [ins| //]. move=> [<- <-]. - set vp := pof_val p.(vtype) (Vword (sub_region_addr (sub_region_at_ofs sry (Some ofs) len))). + set vp := Vword (sub_region_addr (sub_region_at_ofs sry (Some ofs) len)). exists (with_vm s2 (evm s2).[p <- vp]); split. + rewrite /vp -sub_region_addr_offset haddr -GRing.addrA -wrepr_add. apply (mov_ofsP hsaparams _ P'_globs he1 Hmov_ofs). - by case: (p) hlocal.(wfr_rtype) => ? pn /= ->. + rewrite /=; set v1 := Vword _. + have htr : type_of_val v1 = vtype (with_var x p) by rewrite hlocal.(wfr_rtype). + by rewrite write_var_eq_type. (* valid_state update *) - by apply (valid_state_set_move_regptr hvs hwf hlx (heqval _)). - move=> s ofs' ws z f hlx hlocal. + have htyp := hlocal.(wfr_rtype). + have := valid_state_set_move_regptr _ hvs hwf hlx h; apply => //. + by rewrite vm_truncate_val_eq. + move=> s ofs' ws z f hlx hlocal /=. case hi2: (if _ then _ else _) => {i2} [i2|//] [<- <-]. - have {hi2} [mem2 [hsemi hss hvalideq hreadeq hreadptr]]: exists mem2, [/\ sem_i P' rip s2 i2 (with_mem s2 mem2), @@ -2521,7 +2486,7 @@ Proof. move => _ hi2. exists mem2; split. + apply (mov_ofsP hsaparams _ P'_globs he1 hi2). - rewrite /= vs_rsp /= !truncate_word_u /=. + rewrite /= /get_var vs_rsp /= !truncate_word_u /=. by rewrite -(sub_region_addr_stkptr hlocal) hmem2. + by apply (Memory.write_mem_stable hmem2). + by move=> ??; apply (write_validw_eq hmem2). @@ -2530,7 +2495,7 @@ Proof. by rewrite wrepr_add GRing.addrA -haddr -sub_region_addr_offset. exists (with_mem s2 mem2); split=> //. - by apply (valid_state_set_stack_ptr hvs hwf hlx hss hvalideq hreadeq hreadptr (heqval _)). + by apply (valid_state_set_stack_ptr hvs hwf hlx hss hvalideq hreadeq hreadptr h); rewrite htreq. (* interestingly, we can prove that n = Z.to_pos len = Z.to_pos (arr_size ws len2) but it does not seem useful @@ -2557,11 +2522,11 @@ Qed. Lemma alloc_protect_ptrP m0 s1 s2 s1' rmap1 rmap2 ii r tag e msf vmsf v v' n i2 : valid_state rmap1 m0 s1 s2 -> - sem_pexpr gd s1 e = ok v -> - sem_pexpr gd s1 msf = ok vmsf -> + sem_pexpr true gd s1 e = ok v -> + sem_pexpr true gd s1 msf = ok vmsf -> truncate_val ty_msf vmsf = ok (@Vword msf_size 0%R) -> truncate_val (sarr n) v = ok v' -> - write_lval gd r v' s1 = ok s1' -> + write_lval true gd r v' s1 = ok s1' -> alloc_protect_ptr shparams pmap rmap1 ii r tag e msf = ok (rmap2, i2) -> ∃ s2' : estate, sem_i P' rip s2 i2 s2' ∧ valid_state rmap2 m0 s1' s2'. Proof. @@ -2586,7 +2551,7 @@ Proof. have hpky: valid_vpk rmap1 s2 y.(gv) sry vpky. + have /wfr_gptr := hgvalidy. by rewrite hkindy => -[_ [[]] <-]. - move=> [e1 ofs2] /dup [] hmk_addr /(mk_addr_pexprP _ hwfpky hpky) [w [he1 haddr]] [] <- _ <-. + move=> [e1 ofs2] /dup [] hmk_addr /(mk_addr_pexprP true _ hwfpky hpky) [w [he1 haddr]] [] <- _ <-. have [? [ay [hgety hay]]] := get_Pvar_subP he hgete erefl; subst n. have hread: forall bytes, @@ -2604,32 +2569,26 @@ Proof. by apply zbetween_zone_refl. case: r hr hgetr hw => //=. - move=> _ _ [-> <-]. - rewrite /write_lval /write_var; t_xrbindP=> vm1'; apply: set_varP; last first. - + by move=> /is_sboolP h1 h2; exfalso; move: h2; rewrite h1. - case: x => -[xty xn] xii; case: xty => //=. - move=> nx ax hax <- <-. - set x := {| vname := xn |}. + move=> _ _ [-> <-] /write_varP [->] _ /vm_truncate_valE [hxty _]. case hlx: (get_local pmap x) => [pk|//]. have /wf_locals hlocal := hlx. have heqval: forall bytes, eq_sub_region_val x.(vtype) (emem s2) (sub_region_at_ofs sry (Some ofs) len) - bytes (Varr ax). + bytes (Varr a'). + move=> bytes. by split=> // off /hread{hread}hread w' /(cast_get8 hax) /hread. have hwf: wf_sub_region (sub_region_at_ofs sry (Some ofs) len) x.(vtype). - + apply: (wf_sub_region_subtype _ hwfy'). by rewrite /= (WArray.cast_len hax). - - rewrite -(WArray.castK ax). - + + by apply: (wf_sub_region_subtype _ hwfy'); rewrite hxty. case: pk hlx hlocal => //. move=> p hlx hlocal. t_xrbindP => msf' hmsf' i hi <- <-. - set vp := pof_val p.(vtype) (Vword (sub_region_addr (sub_region_at_ofs sry (Some ofs) len))). + set vp := (Vword (sub_region_addr (sub_region_at_ofs sry (Some ofs) len))). exists (with_vm s2 (evm s2).[p <- vp]); split; last first. - + by apply (valid_state_set_move_regptr hvs hwf hlx (heqval _)). + + apply: (valid_state_set_move_regptr _ hvs hwf hlx) => //. + + by apply: ptr_prop hlx. + by rewrite hxty. + by rewrite {2}hxty /= eqxx; apply: heqval. move: hi; rewrite /lower_protect_ptr_fail /slh_lowering.lower_slho /=. case heq: slh_lowering.shp_lower => [ [[xs o] es] | //] [<-]. have := slh_lowering_proof.hshp_spec_lower hshparams heq. @@ -2643,7 +2602,7 @@ Proof. + by rewrite h1 (alloc_eP hvs hmsf' hmsf). + by rewrite /exec_sopn /= hve1 htr /= wrepr0 GRing.addr0. rewrite /write_var /set_var /s2' /vp -sub_region_addr_offset haddr wrepr0 !GRing.addr0 /=. - by case: (p) (wfr_rtype hlocal) => //= ?? ->. + by rewrite (wfr_rtype hlocal) cmp_le_refl orbT. Qed. Lemma is_array_initP e : reflect (exists n, e = Parr_init n) (is_array_init e). @@ -2654,9 +2613,9 @@ Qed. Lemma alloc_array_move_initP m0 s1 s2 s1' rmap1 rmap2 r tag e v v' n i2 : valid_state rmap1 m0 s1 s2 -> - sem_pexpr gd s1 e = ok v -> + sem_pexpr true gd s1 e = ok v -> truncate_val (sarr n) v = ok v' -> - write_lval gd r v' s1 = ok s1' -> + write_lval true gd r v' s1 = ok s1' -> alloc_array_move_init saparams pmap rmap1 r tag e = ok (rmap2, i2) → ∃ s2' : estate, sem_i P' rip s2 i2 s2' ∧ valid_state rmap2 m0 s1' s2'. Proof. @@ -3244,12 +3203,12 @@ Lemma alloc_call_args_aux_incl rmap sao_params args rmap2 l : incl rmap2 rmap. Proof. by apply alloc_call_args_aux_incl_aux. Qed. -Lemma alloc_call_arg_auxP m0 rmap0 rmap s1 s2 opi e1 rmap2 bsr e2 v1 : +Lemma alloc_call_arg_auxP wdb m0 rmap0 rmap s1 s2 opi e1 rmap2 bsr e2 v1 : valid_state rmap0 m0 s1 s2 -> alloc_call_arg_aux pmap rmap0 rmap opi e1 = ok (rmap2, (bsr, e2)) -> - sem_pexpr gd s1 e1 = ok v1 -> + sem_pexpr wdb gd s1 e1 = ok v1 -> exists v2, [/\ - sem_pexpr [::] s2 e2 = ok v2, + sem_pexpr wdb [::] s2 e2 = ok v2, wf_arg (emem s1) (emem s2) opi v1 v2, forall b sr, bsr = Some (b, sr) -> v2 = Vword (sub_region_addr sr) /\ wf_sub_region sr (type_of_val v1) & @@ -3273,13 +3232,17 @@ Proof. have /(check_gvalid_wf wfr_wf) /= hwf := hgvalid. move=> {rmap2}rmap2 hclear /(check_alignP hwf) halign <- <- <- hget /=. have /wfr_gptr := hgvalid. - rewrite /get_var_kind /= hlx => -[_ [[<-] /=]]. - rewrite get_gvar_nglob // => ->. + rewrite /get_var_kind /= hlx => -[_ [[<-] /=]] hgetp. + rewrite get_gvar_nglob // /get_var /= hgetp /= orbT /= => {hgetp}. (* We have [size_val v1 <= size_slot x] by [have /= hle := size_of_le (type_of_get_gvar hget)]. The inequality is sufficient for most of the proof. But we even have the equality, so let's use it. *) - have /(wfr_val hgvalid) [_ /= hty] := hget. + have hget' : get_gvar true gd (evm s1) {| gv := x; gs := Slocal |} = ok v1. + + have /is_sarrP [len hty] := wfr_type (wf_pmap0.(wf_locals) hlx). + move: hget; rewrite /get_gvar /= => /get_varP []. + by rewrite /get_var hty => <- ? /compat_valEl [a] ->. + have /(wfr_val hgvalid) [hread /= hty] := hget'. eexists; split; first by reflexivity. + eexists; split; first by reflexivity. split=> //. @@ -3300,7 +3263,6 @@ Proof. rewrite hty. by apply (zbetween_sub_region_addr hwf). move=> off w /dup[] /get_val_byte_bound; rewrite hty => hoff. - have /(wfr_val hgvalid) [hread _] := hget. apply hread. rewrite memi_mem_U8; apply: mem_incl_r hmem; rewrite subset_interval_of_zone. rewrite -(Z.add_0_l off). @@ -3315,12 +3277,12 @@ Proof. by rewrite hty; apply incl_refl. Qed. -Lemma alloc_call_args_auxP rmap m0 s1 s2 sao_params args rmap2 l vargs1 : +Lemma alloc_call_args_auxP wdb rmap m0 s1 s2 sao_params args rmap2 l vargs1 : valid_state rmap m0 s1 s2 -> alloc_call_args_aux pmap rmap sao_params args = ok (rmap2, l) -> - sem_pexprs gd s1 args = ok vargs1 -> + sem_pexprs wdb gd s1 args = ok vargs1 -> exists vargs2, [/\ - sem_pexprs [::] s2 (map snd l) = ok vargs2, + sem_pexprs wdb [::] s2 (map snd l) = ok vargs2, Forall3 (wf_arg (emem s1) (emem s2)) sao_params vargs1 vargs2, Forall3 (fun bsr varg1 varg2 => forall (b:bool) (sr:sub_region), bsr = Some (b, sr) -> varg2 = Vword (sub_region_addr sr) /\ wf_sub_region sr (type_of_val varg1)) (map fst l) vargs1 vargs2 & @@ -3486,12 +3448,12 @@ Proof. Qed. (* Full spec including [disjoint_values] *) -Lemma alloc_call_argsP rmap m0 s1 s2 sao_params args rmap2 l vargs1 : +Lemma alloc_call_argsP wdb rmap m0 s1 s2 sao_params args rmap2 l vargs1 : valid_state rmap m0 s1 s2 -> alloc_call_args pmap rmap sao_params args = ok (rmap2, l) -> - sem_pexprs gd s1 args = ok vargs1 -> + sem_pexprs wdb gd s1 args = ok vargs1 -> exists vargs2, [/\ - sem_pexprs [::] s2 (map snd l) = ok vargs2, + sem_pexprs wdb [::] s2 (map snd l) = ok vargs2, Forall3 (wf_arg (emem s1) (emem s2)) sao_params vargs1 vargs2, disjoint_values sao_params vargs1 vargs2, Forall3 (fun bsr varg1 varg2 => forall (b:bool) (sr:sub_region), bsr = Some (b, sr) -> @@ -3669,42 +3631,42 @@ Qed. (* Another lemma on [set_sub_region]. See [valid_state_set_move_regptr]. *) -Lemma valid_state_set_sub_region_regptr rmap m0 s1 s2 sr ty (x:var_i) ofs ty2 p rmap2 v : +Lemma valid_state_set_sub_region_regptr wdb rmap m0 s1 s2 sr ty (x:var_i) ofs ty2 p rmap2 v : + type_of_val (Vword (sub_region_addr sr)) = vtype p -> valid_state rmap m0 s1 s2 -> wf_sub_region sr ty -> subtype x.(vtype) ty -> (forall zofs, ofs = Some zofs -> 0 <= zofs /\ zofs + size_of ty2 <= size_of ty) -> get_local pmap x = Some (Pregptr p) -> set_sub_region rmap x sr ofs (size_of ty2) = ok rmap2 -> - eq_sub_region_val x.(vtype) (emem s2) sr (get_var_bytes rmap2 sr.(sr_region) x) v -> - valid_state rmap2 m0 (with_vm s1 (evm s1).[x <- pof_val x.(vtype) v]) - (with_vm s2 (evm s2).[p <- pof_val p.(vtype) (Vword (sub_region_addr sr))]). + truncatable wdb (vtype x) v -> + eq_sub_region_val x.(vtype) (emem s2) sr (get_var_bytes rmap2 sr.(sr_region) x) (vm_truncate_val (vtype x) v) -> + valid_state rmap2 m0 (with_vm s1 (evm s1).[x <- v]) + (with_vm s2 (evm s2).[p <- Vword (sub_region_addr sr)]). Proof. - move=> hvs hwf hsub hofs hlx hset heqval. + move=> h hvs hwf hsub hofs hlx hset htrx heqval. have hwf' := sub_region_at_ofs_wf hwf hofs. have hwf'' := wf_sub_region_subtype hsub hwf. have /wf_locals /= hlocal := hlx. case:(hvs) => hscs hvalid hdisj hincl hincl2 hunch hrip hrsp heqvm hwfr heqmem hglobv htop. constructor=> //=. - + rewrite get_var_neq //. - by apply hlocal.(wfr_not_vrip). - + rewrite get_var_neq //. - by apply hlocal.(wfr_not_vrsp). + + rewrite Vm.setP_neq //. + by apply/eqP/hlocal.(wfr_not_vrip). + + rewrite Vm.setP_neq //. + by apply/eqP/hlocal.(wfr_not_vrsp). + move=> y hget hnnew. - rewrite get_var_neq; last by rewrite /get_local in hlx; congruence. - rewrite get_var_neq; last by have := hlocal.(wfr_new); congruence. + rewrite Vm.setP_neq; last by apply/eqP; rewrite /get_local in hlx; congruence. + rewrite Vm.setP_neq; last by apply/eqP; have := hlocal.(wfr_new); congruence. by apply heqvm. case: (hwfr) => hwfsr hval hptr; split. + apply (wfr_WF_set hwfsr hwf''). by have [_ ->] := set_sub_regionP hset. + move=> y sry bytesy vy. move=> /(check_gvalid_set_sub_region hwf'' hset) []. - + case: x heqval {hwf hsub hofs hlx hset hwf' hwf'' hlocal} => x xii /= heqval. - move=> [? ? <- ->]; subst x. - rewrite get_gvar_eq //. - case: heqval => hread hty'. - apply on_vuP => //; rewrite -hty'. - by move => ? hof hto; rewrite -hto (pto_val_pof_val hof) hty'. + + move=> [/negP h1 h2 <- ->]. + rewrite /get_gvar is_lvar_is_glob h1 -h2 get_var_eq //; first by t_xrbindP => hd <-. + have /is_sarrP [len hty] := wfr_type (wf_pmap0.(wf_locals) hlx). + by move: htrx; rewrite hty => /vm_truncate_valEl_wdb /= [? ->]. move=> [? [bytes [hgvalid ->]]]. rewrite get_gvar_neq => // /(wfr_val hgvalid). assert (hwfy := check_gvalid_wf wfr_wf hgvalid). @@ -3716,16 +3678,13 @@ Proof. have /set_sub_regionP [_ ->] /= := hset. rewrite Mvar.setP; case: eqP. + move=> <- [<-]. - exists (Pregptr p); split=> //=. - rewrite get_var_eq hlocal.(wfr_rtype). - rewrite /on_vu /pof_val. - by rewrite to_pword_u. + exists (Pregptr p); split=> //=; rewrite Vm.setP_eq; first by rewrite vm_truncate_val_eq. move=> hneq /hptr [pk [hly hpk]]. exists pk; split=> //. case: pk hly hpk => //=. + move=> py hly. have ? := hlocal.(wfr_distinct) hly hneq. - by rewrite get_var_neq. + by rewrite Vm.setP_neq //; apply /eqP. move=> s osf ws z f hly hpk. rewrite /check_stack_ptr get_var_bytes_set_pure_bytes. case: eqP => [_|//]. @@ -3740,15 +3699,15 @@ Lemma get_regptrP x p : Mvar.get pmap.(locals) x = Some (Pregptr p). Proof. by rewrite /get_regptr; case heq: get_local => [[]|] // [<-]. Qed. -Lemma alloc_lval_callP rmap m0 s1 s2 srs r oi rmap2 r2 vargs1 vargs2 vres1 vres2 s1' : +Lemma alloc_lval_callP wdb rmap m0 s1 s2 srs r oi rmap2 r2 vargs1 vargs2 vres1 vres2 s1' : valid_state rmap m0 s1 s2 -> alloc_lval_call pmap srs rmap r oi = ok (rmap2, r2) -> Forall3 (fun bsr varg1 varg2 => forall (b:bool) (sr:sub_region), bsr = Some (b, sr) -> varg2 = Vword (sub_region_addr sr) /\ wf_sub_region sr (type_of_val varg1)) (map fst srs) vargs1 vargs2 -> wf_result (emem s2) vargs1 vargs2 oi vres1 vres2 -> - write_lval gd r vres1 s1 = ok s1' -> + write_lval wdb gd r vres1 s1 = ok s1' -> exists s2', [/\ - write_lval [::] r2 vres2 s2 = ok s2' & + write_lval wdb [::] r2 vres2 s2 = ok s2' & valid_state rmap2 m0 s1' s2']. Proof. move=> hvs halloc haddr hresult hs1'. @@ -3758,45 +3717,40 @@ Proof. t_xrbindP=> /check_lval_reg_callP hcheck <- <-. case: hcheck. + move=> [ii [ty ?]]; subst r. - move: hs1' => /= /write_noneP [->] h; exists s2; split => //. - by rewrite /write_none; case: h => [ [? ->]| [-> ->]]. + by move /write_noneP : hs1';rewrite /= /write_none => -[-> -> ->]; exists s2. move=> [x [? hlx hnnew]]; subst r. - move: hs1'; rewrite /= /write_var. - t_xrbindP=> vm1 hvm1 <- /=. - by apply: set_varP hvm1=> [v' hv <- | hb hv <-]; rewrite /set_var hv /= ?hb /=; - eexists;(split;first by reflexivity) => //; apply valid_state_set_var. + move /write_varP: hs1' => [-> hdb h] /=. + rewrite (write_var_truncate hdb h) //. + by eexists;(split;first by reflexivity) => //; apply valid_state_set_var. move=> [w [-> hresp]]. case hnth: nth => [[[b sr]|//] ?]. have {hnth}hnth: nth None (map fst srs) i = Some (b, sr). + rewrite (nth_map (None, Pconst 0)) ?hnth //. by apply (nth_not_default hnth ltac:(discriminate)). case: r hs1' => //. - + move=> ii ty /= /write_noneP [-> _] [<- <-] /=; rewrite /write_none /=. - by eexists. + + move=> ii ty /= /write_noneP [-> ? hdb][<- <-] /=; rewrite /write_none /=. + by rewrite cmp_le_refl /= /DB !orbT /=; eexists. t_xrbindP=> x hs1' p /get_regptrP hlx {rmap2}rmap2 hset <- <-. have /wf_locals hlocal := hlx. - move: hs1'; rewrite /= /write_var; t_xrbindP=> vm1. + move/write_varP: hs1' => [-> hdb h]. have /is_sarrP [nx hty] := hlocal.(wfr_type). - apply: set_varP; last by rewrite {1}hty. - case: x hty hset hlx hlocal => -[_ xn] xii /= -> /= hset hlx hlocal. - move=> ax /to_arrI ? <- <-; subst vres1. have := Forall3_nth haddr None (Vbool true) (Vbool true) (nth_not_default hnth ltac:(discriminate)) _ _ hnth. rewrite hresp.(wrp_args) => -[[?] hwf]; subst w. - - set vp := pof_val p.(vtype) (Vword (sub_region_addr sr)). + set vp := Vword (sub_region_addr sr). exists (with_vm s2 (evm s2).[p <- vp]). - split. - + rewrite /set_var /vp. - by case: (p) hlocal.(wfr_rtype) => -[_ pn] pii /= ->. - have := (valid_state_set_sub_region_regptr hvs _ (subtype_refl _) _ hlx hset (x:={|v_var:=_;v_info:=xii|}) (v:=Varr ax)) => /=; rewrite WArray.castK; apply. + have : type_of_val vp = vtype p by rewrite hlocal.(wfr_rtype). + split; first by apply write_var_eq_type => //; rewrite /DB /= orbT. + have : type_of_val vres1 = sarr nx. + + by move/vm_truncate_valEl_wdb: h; rewrite hty /= => -[a ->]. + move=> /type_of_valI -[a' ?]; subst vres1. + have /vm_truncate_valE_wdb [? heq]:= h. + apply: (valid_state_set_sub_region_regptr (wdb:= false) _ hvs _ (subtype_refl _) _ hlx hset) => //. + apply: wf_sub_region_subtype hwf. apply: subtype_trans hresp.(wrp_subtype). - by apply /eqP. + by rewrite hty. + by move=> _ [<-] /=; lia. - split=> //. - move=> off hmem w /=. - by apply hresp.(wrp_read). + by rewrite heq; split => //= off hmem w; apply hresp.(wrp_read). Qed. Lemma alloc_lval_call_lv_write_mem srs rmap r oi rmap2 r2 : @@ -3815,15 +3769,15 @@ Proof. by move=> [x [-> _ _]]. Qed. -Lemma alloc_call_resP rmap m0 s1 s2 srs ret_pos rs rmap2 rs2 vargs1 vargs2 vres1 vres2 s1' : +Lemma alloc_call_resP wdb rmap m0 s1 s2 srs ret_pos rs rmap2 rs2 vargs1 vargs2 vres1 vres2 s1' : valid_state rmap m0 s1 s2 -> alloc_call_res pmap rmap srs ret_pos rs = ok (rmap2, rs2) -> Forall3 (fun bsr varg1 varg2 => forall (b:bool) (sr:sub_region), bsr = Some (b, sr) -> varg2 = Vword (sub_region_addr sr) /\ wf_sub_region sr (type_of_val varg1)) (map fst srs) vargs1 vargs2 -> Forall3 (wf_result (emem s2) vargs1 vargs2) ret_pos vres1 vres2 -> - write_lvals gd s1 rs vres1 = ok s1' -> + write_lvals wdb gd s1 rs vres1 = ok s1' -> exists s2', - write_lvals [::] s2 rs2 vres2 = ok s2' /\ + write_lvals wdb [::] s2 rs2 vres2 = ok s2' /\ valid_state rmap2 m0 s1' s2'. Proof. move=> hvs halloc haddr. @@ -3840,14 +3794,14 @@ Proof. by eexists; split; first by reflexivity. Qed. -Lemma check_resultP rmap m0 s1 s2 srs params (sao_return:option nat) res1 res2 vres1 vargs1 vargs2 : +Lemma check_resultP wdb rmap m0 s1 s2 srs params (sao_return:option nat) res1 res2 vres1 vargs1 vargs2 : valid_state rmap m0 s1 s2 -> Forall3 (fun osr (x : var_i) v => osr <> None -> subtype x.(vtype) (type_of_val v)) srs params vargs1 -> List.Forall2 (fun osr varg2 => forall sr, osr = Some sr -> varg2 = Vword (sub_region_addr sr)) srs vargs2 -> check_result pmap rmap srs params sao_return res1 = ok res2 -> - get_var (evm s1) res1 = ok vres1 -> + get_var wdb (evm s1) res1 = ok vres1 -> exists vres2, - get_var (evm s2) res2 = ok vres2 /\ + get_var wdb (evm s2) res2 = ok vres2 /\ wf_result (emem s2) vargs1 vargs2 sao_return vres1 vres2. Proof. move=> hvs hsize haddr hresult hget. @@ -3857,7 +3811,7 @@ Proof. t_xrbindP=> /eqP heqty -[sr' _] /check_validP [bytes [hgvalid -> hmem]]. move=> /= /eqP ? p /get_regptrP hlres1 <-; subst sr'. have /wfr_gptr := hgvalid. - rewrite /get_var_kind /= /get_local hlres1 => -[_ [[<-] /= ->]]. + rewrite /get_var_kind /= /get_var /get_local hlres1 => -[? [[<-] /= ->]] /=; rewrite orbT /=. eexists; split; first by reflexivity. eexists; split; first by reflexivity. split. @@ -3866,7 +3820,12 @@ Proof. rewrite heqty. apply (Forall3_nth hsize None res1 (Vbool true) (nth_not_default heq ltac:(discriminate))). by rewrite heq. - assert (hval := wfr_val hgvalid hget). + have hget' : get_var true (evm s1) res1 = ok vres1. + + have /is_sarrP [len hty] := wfr_type (wf_pmap0.(wf_locals) hlres1). + move: hget; rewrite /get_gvar /= => /get_varP []. + by rewrite /get_var hty => <- ? /compat_valEl [a] ->. + + assert (hval := wfr_val hgvalid hget'). case: hval => hread hty. move=> off w /dup[] /get_val_byte_bound; rewrite hty => hoff. apply hread. @@ -3880,15 +3839,15 @@ Proof. by have := get_var_kindP hvs hlres1 hnnew hget. Qed. -Lemma check_resultsP rmap m0 s1 s2 srs params sao_returns res1 res2 vargs1 vargs2 : +Lemma check_resultsP wdb rmap m0 s1 s2 srs params sao_returns res1 res2 vargs1 vargs2 : valid_state rmap m0 s1 s2 -> Forall3 (fun osr (x : var_i) v => osr <> None -> subtype x.(vtype) (type_of_val v)) srs params vargs1 -> List.Forall2 (fun osr varg2 => forall sr, osr = Some sr -> varg2 = Vword (sub_region_addr sr)) srs vargs2 -> check_results pmap rmap srs params sao_returns res1 = ok res2 -> forall vres1, - mapM (λ x : var_i, get_var (evm s1) x) res1 = ok vres1 -> + mapM (λ x : var_i, get_var wdb (evm s1) x) res1 = ok vres1 -> exists vres2, - mapM (λ x : var_i, get_var (evm s2) x) res2 = ok vres2 /\ + mapM (λ x : var_i, get_var wdb (evm s2) x) res2 = ok vres2 /\ Forall3 (wf_result (emem s2) vargs1 vargs2) sao_returns vres1 vres2. Proof. move=> hvs hsize haddr. @@ -3938,15 +3897,15 @@ Proof. move=> hvs hnrip hnrsp hnew hneq. case:(hvs) => hscs hvalid hdisj hincl hincl2 hunch hrip hrsp heqvm hwfr heqmem hglobv htop. constructor=> //=. - + by rewrite get_var_neq. - + by rewrite get_var_neq. - + by move=> y ??; rewrite get_var_neq; [auto|congruence]. + + by rewrite Vm.setP_neq //; apply /eqP. + + by rewrite Vm.setP_neq //; apply /eqP. + + by move=> y ??; rewrite Vm.setP_neq; [auto|apply/eqP;congruence]. case: (hwfr) => hwfsr hval hptr; split=> //. move=> y sry /hptr [pky [hly hpk]]. rewrite hly. eexists; split; first by reflexivity. case: pky hly hpk => //= p hly hgetp. - rewrite get_var_neq //. + rewrite Vm.setP_neq //; apply/eqP. by apply: hneq hly. Qed. @@ -4049,9 +4008,9 @@ Qed. Lemma alloc_syscallP ii rmap rs o es rmap2 c m0 s1 s2 ves scs m vs s1' : alloc_syscall saparams pmap ii rmap rs o es = ok (rmap2, c) -> valid_state rmap m0 s1 s2 -> - sem_pexprs gd s1 es = ok ves -> - sem.exec_syscall (escs s1) (emem s1) o ves = ok (scs, m, vs) -> - write_lvals gd (with_scs (with_mem s1 m) scs) rs vs = ok s1' -> + sem_pexprs true gd s1 es = ok ves -> + exec_syscall_u (escs s1) (emem s1) o ves = ok (scs, m, vs) -> + write_lvals true gd (with_scs (with_mem s1 m) scs) rs vs = ok s1' -> exists s2', sem P' rip s2 c s2' /\ valid_state rmap2 m0 s1' s2'. Proof. move=> halloc hvs. @@ -4061,19 +4020,12 @@ Proof. case: rs => // -[] // x [] //. case: es => // -[] // g [] //. t_xrbindP=> pg /get_regptrP hlg px /get_regptrP hlx srg /get_sub_regionP hgetg {rmap2}rmap2 hrmap2 <- <-{c}. - rewrite /= /exec_getrandom /=. + rewrite /= /exec_getrandom_u /=. t_xrbindP=> vg hgvarg <-{ves} [_ _] ag' /to_arrI ? a2 hfill [<- <-] <-{scs} <-{m} <-{vs} /=; subst vg. - t_xrbindP=> {s1'}s1' hw <-. + t_xrbindP=> {s1'}s1' /write_varP + <- => -[-> hdb h]. have /wf_locals /= hlocal := hlx. - have /is_sarrP [nx hty] := hlocal.(wfr_type). - move: hw; rewrite /write_var. - t_xrbindP=> vm1' hset <-{s1'}. - case: x hty hlx hrmap2 hlocal hset => -[xty xn] xi. - set x := {| v_info := xi |}. - move=> hty; rewrite /= in hty; subst xty => hlx hrmap2 hlocal. - apply: set_varP => //= ax hcastx <-{vm1'}. - + have /vm_truncate_valE [hty htreq]:= h. set i1 := (X in [:: X; _]). set i2 := (X in [:: _; X]). @@ -4095,9 +4047,7 @@ Proof. have -> /= := type_of_get_gvar_array hgvarg; lia. have /= hwfg' := sub_region_at_ofs_wf hwfg hofs. have hsub: subtype x.(vtype) g.(gv).(vtype). - + have -> /= := type_of_get_gvar_array hgvarg. - apply /eqP. - by move/WArray.cast_len: hcastx => ->. + + by have -> /= := type_of_get_gvar_array hgvarg; rewrite hty. (* clear the argument *) have [rmap1 [rmap2' [hrmap1 hrmap2' hincl2]]] := set_sub_region_clear hrmap2. @@ -4140,37 +4090,30 @@ Proof. move: hfillm; rewrite -sub_region_addr_offset wrepr0 GRing.addr0 => hfillm. (* write the result *) - set s1''' := with_vm s1'' (evm s1'').[x <- ok ax]. - set s2''' := with_vm s2'' (evm s2'').[px <- pof_val px.(vtype) (Vword (sub_region_addr srg))]. + set s1''' := with_vm s1'' (evm s1'').[x <- Varr a2]. + set s2''' := with_vm s2'' (evm s2'').[px <- Vword (sub_region_addr srg)]. have hvs2: valid_state rmap2' m0 s1''' s2'''. - + rewrite /s1''' /s2''' -WArray.castK. - apply (valid_state_set_sub_region_regptr hvs1'' hwfg hsub hofs hlx hrmap2' (v:=Varr ax)). - split=> // off hmem w /dup[] /get_val_byte_bound /= hoff /(cast_get8 hcastx). - have hle := WArray.cast_len hcastx. + + rewrite /s1''' /s2'''. + apply: (valid_state_set_sub_region_regptr _ hvs1'' hwfg hsub hofs hlx hrmap2' h). + + by rewrite hlocal.(wfr_rtype). + rewrite htreq; split=> // off hmem w /dup[] /get_val_byte_bound /= hoff. rewrite (WArray.fill_get8 hfill) (fill_mem_read8_no_overflow _ hfillm) -?(WArray.fill_size hfill) ?positive_nat_Z /=; try lia. by case: andb. (* wrap up *) - exists s2'''; split. - + apply (Eseq (s2 := s2')) => //. - apply sem_seq1; constructor. - apply: Esyscall. - + rewrite /= /get_gvar /=. - have /wfr_ptr := hgetg; rewrite /get_local hlg => -[_ [[<-] /= ->]] /=. - rewrite get_var_eq. - assert (htlen := wt_len). - case: (vxlen pmap) htlen => _ vxlenn /= ->. - by rewrite /= sumbool_of_boolET. - + rewrite /= /exec_syscall_s /= !truncate_word_u /=. - rewrite /exec_getrandom_s_core wunsigned_repr_small; last by lia. - by rewrite -vs_scs hfillm. - rewrite /= /write_var /s2''' /=. - assert (htlen := wt_len). - case: (vxlen pmap) htlen => _ vxlenn /= ->. - by case: (px) hlocal.(wfr_rtype) => -[_ pxn] pxi /= -> /=. - by apply (valid_state_Incl hincl2). + exists s2'''; split; last by apply (valid_state_Incl hincl2). + apply (Eseq (s2 := s2')) => //. + apply sem_seq1; constructor. + apply: Esyscall. + + rewrite /= /get_gvar /= /get_var. + have /wfr_ptr := hgetg; rewrite /get_local hlg => -[_ [[<-] /= ->]] /=. + by rewrite Vm.setP_eq wt_len vm_truncate_val_eq //; eauto. + + rewrite /= /exec_syscall_s /= !truncate_word_u /=. + rewrite /exec_getrandom_s_core wunsigned_repr_small; last by lia. + by rewrite -vs_scs hfillm. + by rewrite /= LetK; apply write_var_eq_type; rewrite // hlocal.(wfr_rtype). Qed. End WITH_PARAMS. diff --git a/proofs/compiler/stack_alloc_proof_2.v b/proofs/compiler/stack_alloc_proof_2.v index 14e885381..43f3d76c3 100644 --- a/proofs/compiler/stack_alloc_proof_2.v +++ b/proofs/compiler/stack_alloc_proof_2.v @@ -16,7 +16,6 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope vmap. Local Open Scope seq_scope. Local Open Scope Z_scope. @@ -37,6 +36,8 @@ Variable global_alloc : seq (var * wsize * Z). Let glob_size := Z.of_nat (size global_data). Context + {wsw : WithSubWord} + {dc:DirectCall} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} @@ -49,7 +50,6 @@ Context Notation gd := (p_globs P). - Lemma ztakeP (A:Type) z (l l1 l2:list A) : ztake z l = Some(l1, l2) -> l = l1 ++ l2 /\ size l1 = Z.to_nat z. Proof. @@ -1057,7 +1057,7 @@ Proof. by move=> _; apply hneq'. move=> sy ofsy wsy zy yf [] hslot hty hlen hofs hw hal hcmp hal2 haddr hnew' hneq'. split=> //=. - rewrite /get_local /= => w sw ofsw wsw zw wf. + rewrite /get_local /= => w sw ofsw wsw' zw wf. rewrite Mvar.setP. case: eqP => //. by move=> _; apply hneq'. @@ -1102,7 +1102,7 @@ Proof. move=> sy ofsy wsy zy yf [] hslot hty' hlen hofs hw hal hcmp hal2 haddr hnew' hneq'. split=> //=. + by apply SvD.F.add_2. - move=> w sw ofsw wsw zw wf. + move=> w sw ofsw wsw' zw wf. rewrite /get_local /= Mvar.setP. case: eqP => //. by move=> _; apply hneq'. @@ -1144,7 +1144,7 @@ Proof. + by rewrite WArray.arr_is_align; apply /eqP. + by rewrite /Addr (pick_slot_locals hin) /Addr_locals /Offset_slots heq. + by apply SvD.F.add_1. - move=> w sw ofsw wsw zw wf. + move=> w sw ofsw wsw' zw wf. rewrite /get_local /= Mvar.setP. case: eqP => //. by move=> _ /hlocals /wfs_new /=; congruence. @@ -1160,7 +1160,7 @@ Proof. move=> sy ofsy wsy zy yf [] /= hslot hty' hlen hofs hw hal hcmp hal2 haddr hnew' hneq'. split=> //=. + by apply SvD.F.add_2. - move=> w sw ofsw wsw zw wf. + move=> w sw ofsw wsw' zw wf. rewrite /get_local /= Mvar.setP. case: eqP. + by move=> _ [_ _ _ _ <-]; congruence. @@ -1178,7 +1178,7 @@ Qed. Lemma add_alloc_wf_rmap locals1' rmap1' vnew1' x pki locals2' rmap2' vnew2' s2 : wf_pmap (lmap locals1' vnew1') rsp rip Slots Addr Writable Align -> add_alloc mglob stack (x, pki) (locals1', rmap1', vnew1') = ok (locals2', rmap2', vnew2') -> - let: s1 := {| escs := scs1; emem := m1; evm := vmap0 |} in + let: s1 := {| escs := scs1; emem := m1; evm := Vm.init |} in wf_rmap (lmap locals1' vnew1') Slots Addr Writable Align P rmap1' s1 s2 -> wf_rmap (lmap locals2' vnew2') Slots Addr Writable Align P rmap2' s1 s2. Proof. @@ -1210,10 +1210,8 @@ Proof. + move=> y sry bytesy vy /check_gvalid_set_move []. + move=> [hg ? _ _]; subst x. rewrite get_gvar_nglob; last by apply /negP. - rewrite /get_var /= Fv.get0. - case: vtype => //= len [<-]. - split=> // off _ w /=. - rewrite WArray.get_empty. + rewrite /get_var /= Vm.initP; t_xrbindP => /is_defined_undef_addr [len] hlen <-. + split; rewrite hlen => // off _ w /=; rewrite WArray.get_empty. by case: ifP. by move=> [] _; apply hval. move=> y sry. @@ -1289,7 +1287,7 @@ Proof. Qed. Lemma init_local_map_wf_rmap s2 : - let: s1 := {| escs := scs1; emem := m1; evm := vmap0 |} in + let: s1 := {| escs := scs1; emem := m1; evm := Vm.init |} in (forall i, 0 <= i < glob_size -> read (emem s2) (rip + wrepr Uptr i)%R U8 = ok (nth 0%R global_data (Z.to_nat i))) -> wf_rmap (lmap locals1 vnew1) Slots Addr Writable Align P rmap1 s1 s2. @@ -1305,7 +1303,7 @@ Proof. /\ wf_rmap (lmap (Mvar.empty ptr_kind, empty, Sv.add vxlen0 (Sv.add vrip0 (Sv.add vrsp0 Sv.empty))).1.1 (Mvar.empty ptr_kind, empty, Sv.add vxlen0 (Sv.add vrip0 (Sv.add vrsp0 Sv.empty))).2) Slots Addr Writable Align P (Mvar.empty ptr_kind, empty, Sv.add vxlen0 (Sv.add vrip0 (Sv.add vrsp0 Sv.empty))).1.2 - {| escs := scs1; emem := m1; evm := vmap0 |} s2. + {| escs := scs1; emem := m1; evm := Vm.init |} s2. + split. + split=> //=. + by apply/SvD.F.add_1. @@ -1372,7 +1370,7 @@ Proof. move=> sy ofsy wsy zy yf [] /= hslot hty' hlen hofs hw hal hcmp hal2 haddr hnew' hneq'. split=> //=. + by apply SvD.F.add_2. - move=> w sw ofsw wsw zw wf. + move=> w sw ofsw wsw' zw wf. rewrite /get_local /= Mvar.setP. case: eqP => //. by move=> _; apply hneq'. @@ -1388,16 +1386,16 @@ Proof. by move=> /SvD.F.add_3; auto. Qed. -Lemma valid_state_init_param rmap m0 s1 s2 vnew1' locals1' sao_param (param:var_i) vnew2' locals2' rmap2' alloc_param : +Lemma valid_state_init_param wdb rmap m0 s1 s2 vnew1' locals1' sao_param (param:var_i) vnew2' locals2' rmap2' alloc_param : wf_pmap (lmap locals1' vnew1') rsp rip Slots Addr Writable Align -> valid_state (lmap locals1' vnew1') glob_size rsp rip Slots Addr Writable Align P rmap m0 s1 s2 -> init_param mglob stack (vnew1', locals1', rmap) sao_param param = ok (vnew2', locals2', rmap2', alloc_param) -> forall s1' varg1 varg2, - write_var param varg1 s1 = ok s1' -> + write_var wdb param varg1 s1 = ok s1' -> (forall pi, sao_param = Some pi -> get_pi param = Some (pi, (varg1, varg2))) -> wf_arg glob_size rip (emem s1) (emem s2) sao_param varg1 varg2 -> exists s2', - write_var alloc_param.2 varg2 s2 = ok s2' /\ + write_var wdb alloc_param.2 varg2 s2 = ok s2' /\ valid_state (lmap locals2' vnew2') glob_size rsp rip Slots Addr Writable Align P rmap2' m0 s1' s2'. Proof. move=> hpmap hvs hparam. @@ -1408,27 +1406,19 @@ Proof. case: sao_param => [pi|]; last first. + move=> [<- <- <- <-]. move=> s1' varg1 varg2 hw _ ->. - move: hw. - rewrite /write_var; t_xrbindP => vm1 hvm1 <- /=. - by apply: set_varP hvm1 => [v' hv <- | hb hv <-]; rewrite /write_var /set_var hv /= ?hb /=; - eexists;(split;first by reflexivity); apply valid_state_set_var. + move/write_varP: hw => [-> hdb h] /=. + rewrite (write_var_truncate hdb h). + by eexists;(split;first by reflexivity); apply valid_state_set_var. t_xrbindP=> /eqP hty1 /Sv_memP hnnew2 /is_sarrP [n hty2]. case heq2: Mvar.get => //. case heq3: Mvar.get => //. case heq4: Mvar.get => //. move=> [? ? <- <-]; subst vnew2' locals2'. - move=> s1' varg1 varg2 hw /(_ _ refl_equal) hpi [w [? hargp]]; subst varg2. - rewrite /write_var /set_var /=. - case: pi.(pp_ptr) hty1 hpmap2 => /= _ pin -> /=. - set p := {| vname := pin |} => hpmap2. - eexists; split; first by reflexivity. - move: hw; rewrite /write_var. + move=> s1' varg1 varg2 hw /(_ _ refl_equal) hpi [w [? hargp]]; subst varg2 => /=. + have hvpi: type_of_val (Vword w) = vtype pi.(pp_ptr) by rewrite hty1. + eexists; split; first by apply: write_var_eq_type => //=; rewrite /DB /= orbT. set valid_state := valid_state. (* hack due to typeclass interacting badly *) - t_xrbindP => vm1 hvm1 <- /=. - apply: set_varP hvm1; last by rewrite {1}hty2. - case: param hty2 hnnew heq1 heq3 heq4 hpi hpmap2 => -[_ paramn] paramii /= -> /=. - set param := {| vname := paramn |} => hnnew heq1 heq3 heq4 hpi hpmap2. - move=> a1 /to_arrI ? <-; subst varg1. + move /write_varP: hw => [-> hdb h]. set sr := sub_region_full _ _. have hin: Sv.In sr.(sr_region).(r_slot) Slots_params. + by apply in_Slots_params => /=; congruence. @@ -1437,28 +1427,26 @@ Proof. + by apply in_Slots; right; right. + by rewrite /Writable (pick_slot_params hin) /Writable_params hpi. + by rewrite /Align (pick_slot_params hin) /Align_params hpi. - + by lia. - by lia. + + by rewrite hty2 /=; lia. + by rewrite hty2 /=; lia. have haddr: w = sub_region_addr Addr sr. + rewrite /sub_region_addr /= wrepr0 GRing.addr0. rewrite /Addr (pick_slot_params hin) /= /Addr_params hpi. by rewrite eq_refl zero_extend_u. - rewrite haddr -(WArray.castK a1). - apply (valid_state_set_move_regptr hpmap2 (x := param) (v:=Varr a1) (p:=p)) => //; last first. - + split=> //. + rewrite haddr. + have := h; rewrite {1}hty2 => /vm_truncate_valEl; rewrite -hty2 => -[a1 heq htreq]. + apply: (valid_state_set_move_regptr hpmap2) => //; last first. + + split; rewrite htreq; last by rewrite /= hty2. move=> off _ w' hget. - rewrite -haddr. - by apply hargp.(wap_read). + by rewrite -haddr; apply hargp.(wap_read); rewrite heq. + + by rewrite /truncatable heq hty2 /= eqxx. + by rewrite /get_local /= Mvar.setP_eq. + + by rewrite hty2. case:(hvs) => hscs hvalid hdisj hincl hincl2 hunch hrip hrsp heqvm hwfr heqmem hglobv htop. split=> //. - + move=> x /=. - rewrite Mvar.setP. - case: eqP => //. - move=> ? hlx hnnew3. - apply heqvm => //. - move=> ?; apply hnnew3. - by apply Sv.add_spec; right. + + move=> x /=;rewrite Mvar.setP. + case: eqP => // ? hlx hnnew3; apply heqvm => // ?. + by apply hnnew3; apply Sv.add_spec; right. case: (hwfr) => hwfsr hval hptr; split=> //. move=> y sry /hptr. rewrite /get_local /= => -[pky [hly hpky]]. @@ -1484,14 +1472,14 @@ Proof. by apply (init_param_wf_pmap hparam). Qed. -Lemma valid_state_init_params m0 vm1 vm2 : +Lemma valid_state_init_params wdb m0 vm1 vm2 : let: s1 := {| escs := scs1; emem := m1; evm := vm1 |} in let: s2 := {| escs := scs1; emem := m2; evm := vm2 |} in valid_state (lmap locals1 vnew1) glob_size rsp rip Slots Addr Writable Align P rmap1 m0 s1 s2 -> forall s1', - write_vars params vargs1 s1 = ok s1' -> + write_vars wdb params vargs1 s1 = ok s1' -> exists s2', - write_vars (map snd alloc_params) vargs2 s2 = ok s2' /\ + write_vars wdb (map snd alloc_params) vargs2 s2 = ok s2' /\ valid_state (lmap locals2 vnew2) glob_size rsp rip Slots Addr Writable Align P rmap2 m0 s1' s2'. Proof. move=> hvs. @@ -1629,8 +1617,11 @@ Lemma init_stk_state_valid_state m3 sz' ws : alloc_stack_spec m2 ws sao.(sao_size) sao.(sao_ioff) sz' m3 -> rsp = top_stack m3 -> vripn <> vrspn -> - let s2 := {| escs := scs1; emem := m3; evm := vmap0.[vrsp0 <- ok (pword_of_word rsp)].[vrip0 <- ok (pword_of_word rip)] |} in - valid_state (lmap locals1 vnew1) glob_size rsp rip Slots Addr Writable Align P rmap1 m2 {| escs := scs1; evm := vmap0; emem := m1 |} s2. + let s2 := {| escs := scs1; emem := m3; evm := + Vm.init.[vrsp0 <- Vword rsp ] + .[vrip0 <- Vword rip ] |} in + valid_state (lmap locals1 vnew1) glob_size rsp rip Slots Addr Writable Align P rmap1 m2 + {| escs := scs1; evm := Vm.init; emem := m1 |} s2. Proof. clear disjoint_zrange_globals_locals. move=> hext hass hrsp hneq /=. @@ -1687,11 +1678,11 @@ Proof. + move=> p hvalid. by rewrite hass.(ass_valid); apply /orP; left. + by move=> p hvalid1 hvalid2 hdisj; apply hass.(ass_read_old8). - + by rewrite get_var_eq. - + rewrite get_var_neq; first by rewrite get_var_eq. - by rewrite /vrip0 /vrsp0; congruence. + + by rewrite Vm.setP_eq /= cmp_le_refl orbT. + + rewrite Vm.setP_neq; first by rewrite Vm.setP_eq /= cmp_le_refl orbT. + by apply/eqP;rewrite /vrip0 /vrsp0; congruence. + move=> x /= hget hnnew. - rewrite !get_var_neq //. + rewrite !Vm.setP_neq //; apply /eqP. + by have /rsp_in_new /= := init_local_map_wf_pmap; congruence. by have /rip_in_new /= := init_local_map_wf_pmap; congruence. + apply init_local_map_wf_rmap. @@ -1964,7 +1955,7 @@ Proof. t_xrbindP => a1 a ha wmsf /to_wordI [sz' [w']] [? hwmsf] /eqP ???; subst wmsf a1 vs vmsf. move: hw => /=; t_xrbindP => s2' hwr ?; subst s2'. have := alloc_protect_ptrP hwf.(wfsl_no_overflow) hwf.(wfsl_align) hpmap P'_globs hshparams hvs hve hvmsf _ _ hwr hi. - move=> /(_ sz); rewrite /truncate_val /= hwmsf /= ha => -[] // s2' [] hsem hval. + move=> /(_ dc sz); rewrite /truncate_val /= hwmsf /= ha => -[] // s2' [] hsem hval. by exists s2'; split => //; apply sem_seq_ir. t_xrbindP => es' he [rmap4 x'] ha /= ? <- m0 s1' hvs hext hsao; subst rmap4. @@ -2307,9 +2298,9 @@ Qed. Lemma mapM2_truncate_val_wf_args m1 m2 fn vargs1 vargs2 : wf_args m1 m2 fn vargs1 vargs2 -> forall tyin vargs1', - mapM2 ErrType truncate_val tyin vargs1 = ok vargs1' -> + mapM2 ErrType dc_truncate_val tyin vargs1 = ok vargs1' -> exists vargs2', - mapM2 ErrType truncate_val + mapM2 ErrType dc_truncate_val (map2 (fun o ty => match o with | Some _ => spointer @@ -2327,12 +2318,14 @@ Proof. rewrite htr /=. case: opi harg => [pi|]. + move=> [p [-> hargp]]. - rewrite /truncate_val /= truncate_word_u /=. + have -> : dc_truncate_val (sword Uptr) (Vword p) = ok (Vword p). + + rewrite /dc_truncate_val; case: ifP => //. + by rewrite /truncate_val /= truncate_word_u. eexists; split; first by reflexivity. constructor=> //. exists p; split=> //. apply: value_uincl_wf_arg_pointer hargp. - by apply (truncate_value_uincl hvarg1'). + by apply (dc_truncate_value_uincl hvarg1'). move=> /= ->. rewrite hvarg1' /=. eexists; split; first by reflexivity. @@ -2343,7 +2336,7 @@ Qed. Lemma mapM2_truncate_val_ptr_eq m1 m2 fn vargs1 vargs2 : wf_args m1 m2 fn vargs1 vargs2 -> forall tyin vargs2', - mapM2 ErrType truncate_val + mapM2 ErrType dc_truncate_val (map2 (fun o ty => match o with | Some _ => spointer @@ -2357,6 +2350,7 @@ Proof. t_xrbindP=> _ varg2' hvarg2' vargs2' /ih{ih}ih <-. constructor=> //. case: opi harg hvarg2' => [pi|//] [p [-> ?]]. + rewrite /dc_truncate_val; case:ifP => [_ [] //| _]. rewrite /truncate_val /= truncate_word_u. by move=> [<-]. Qed. @@ -2400,9 +2394,9 @@ Qed. Lemma mapM2_truncate_val_wf_results m vargs1 vargs2 fn vres1 vres2 : wf_results m vargs1 vargs2 fn vres1 vres2 -> forall tyout vres1', - mapM2 ErrType truncate_val tyout vres1 = ok vres1' -> + mapM2 ErrType dc_truncate_val tyout vres1 = ok vres1' -> exists vres2', - mapM2 ErrType truncate_val + mapM2 ErrType dc_truncate_val (map2 (fun o ty => match o with | Some _ => spointer @@ -2420,12 +2414,14 @@ Proof. rewrite htr /=. case: i hresult => [i|]. + move=> [p [-> hresultp]]. - rewrite /truncate_val /= truncate_word_u /=. + have -> : dc_truncate_val (sword Uptr) (Vword p) = ok (Vword p). + + rewrite /dc_truncate_val; case: ifP => // _. + by rewrite /truncate_val /= truncate_word_u. eexists; split; first by reflexivity. constructor=> //. eexists; split; first by reflexivity. apply: value_uincl_wf_result_pointer hresultp. - by apply (truncate_value_uincl hvr1'). + by apply (dc_truncate_value_uincl hvr1'). move=> /= ->. rewrite hvr1' /=. eexists; split; first by reflexivity. @@ -2440,21 +2436,17 @@ Hypothesis rip_rsp_neq : P'.(p_extra).(sp_rip) <> P'.(p_extra).(sp_rsp). *) Lemma write_vars_subtype A (l:seq (option A)) params : List.Forall2 (fun o (x:var_i) => o <> None -> is_sarr x.(vtype)) l params -> - forall vargs1 s1 s2, - write_vars params vargs1 s1 = ok s2 -> + forall wdb vargs1 s1 s2, + write_vars wdb params vargs1 s1 = ok s2 -> Forall3 (fun o (x:var_i) v => o <> None -> subtype x.(vtype) (type_of_val v)) l params vargs1. Proof. elim {l params}. - + by move=> [|//] _ _ _; constructor. - move=> o x l params harr _ ih [//|varg1 vargs1] /=. + + by move=> ? [|//] _ _ _; constructor. + move=> o x l params harr _ ih wdb [//|varg1 vargs1] /=. t_xrbindP=> s1 s3 s2 hw /ih{ih}ih. constructor=> //. move=> /harr /is_sarrP [n hty]. - move: hw; rewrite /write_var. - t_xrbindP=> vm1 hvm1 _. - apply: set_varP hvm1; last by rewrite {1}hty. - move=> t h _; move: t h; rewrite hty /=. - by move=> _ /to_arrI -> /=. + move/write_varP: hw => [_ _];rewrite hty => /vm_truncate_valEl [> ->] //. Qed. Lemma alloc_stack_spec_wf_args m1 m2 fn vargs1 vargs2 ws sz ioff sz' m3 : @@ -2602,6 +2594,7 @@ Qed. - truncate_val of results, - finalize. *) + Local Lemma Hproc : sem_Ind_proc P ev Pc Pfun. Proof. move=> scs1 m1 _ _ fn fd vargs1' vargs1 _ s1 s1' vres1 vres1' hfd hvargs1' /= [<-] hs1 hsem1 Hc hvres1 hvres1' -> ->. @@ -2616,7 +2609,7 @@ Proof. (* truncate_val of args *) have [vargs2' [hvargs2' hargs']] := mapM2_truncate_val_wf_args hargs hvargs1'. - have huincl := mapM2_truncate_value_uincl hvargs1'. + have huincl := mapM2_dc_truncate_value_uincl hvargs1'. have hptreq := mapM2_truncate_val_ptr_eq hargs hvargs2'. have hdisjv' := value_uincl_disjoint_values hargs hdisjv huincl hptreq. @@ -2637,27 +2630,20 @@ Proof. have hass := Memory.alloc_stackP halloc_stk. set fex := {| sf_align := _ |} in hfd2. set rsp := top_stack m2'. + set vrsp' := {| vtype := spointer; vname := P'.(p_extra).(sp_rsp); |}. + set vrip' := {| vtype := spointer; vname := P'.(p_extra).(sp_rip); |}. + have hinit: - init_stk_state fex (p_extra P') rip {| escs := scs1; emem := m2; evm := vmap0 |} = + init_stk_state fex (p_extra P') rip {| escs := scs1; emem := m2; evm := Vm.init |} = ok {| escs := scs1; emem := m2'; - evm := vmap0 - .[ - {| - vtype := spointer; - vname := P'.(p_extra).(sp_rsp); - |} <- ok (pword_of_word rsp) - ] - .[ - {| - vtype := spointer; - vname := P'.(p_extra).(sp_rip); - |} <- ok (pword_of_word rip) - ]; + evm := Vm.init + .[ vrsp' <- Vword rsp] + .[ vrip' <- Vword rip]; |}. - + by rewrite /init_stk_state halloc_stk /= sumbool_of_boolET !pword_of_wordE. + + by rewrite /init_stk_state halloc_stk /= write_var_eq_type //= write_var_eq_type. have hover := ass_no_overflow hass. have hargs'' := alloc_stack_spec_wf_args hargs' hass. have hext' := alloc_stack_spec_extend_mem hext hass. @@ -2709,11 +2695,11 @@ Proof. (* write_vars of args *) have [s2 [hs2 hvs']] := valid_state_init_params hlayout hargs'' hlocal_map hparams hvs hs1. have hext'': extend_mem (emem s1) (emem s2) rip global_data. - + have /= <- := write_vars_emem hs1. - by have /= <- := write_vars_emem hs2. + + have /= <- := write_vars_memP hs1. + by have /= <- := write_vars_memP hs2. have hsao: wf_sao rsp (emem s2) (local_alloc fn). - + have /= <- := write_vars_emem hs2. + + have /= <- := write_vars_memP hs2. split. + rewrite /enough_size /allocatable_stack. split; first by lia. @@ -2747,7 +2733,7 @@ Proof. + by apply: (Forall2_trans _ (init_params_alloc_params_not_None hparams) (init_params_sarr hparams)); auto. have hsub' := write_vars_subtype harr hs1. have haddr := init_params_alloc_params rsp hargs'' hparams. - have [vres2 [hvres2 hresults]] := check_resultsP hvs''' hsub' haddr hcresults hvres1. + have [vres2 [hvres2 hresults]] := check_resultsP hpmap hvs''' hsub' haddr hcresults hvres1. (* truncate_val of results *) have [vres2' [hvres2' hresults']] := mapM2_truncate_val_wf_results hresults hvres1'. @@ -2764,11 +2750,11 @@ Proof. (* finalize *) have hfss := Memory.free_stackP (emem s2'). have hvalideq1: validw m1 =2 validw (emem s1'). - + have /= -> := write_vars_emem hs1. + + have /= -> := write_vars_memP hs1. by apply (sem_validw_stable_uprog hsem1). have hvalideq2: validw m2 =2 validw (free_stack (emem s2')). + apply: (alloc_free_validw_stable hass _ _ hfss); - have /= -> := write_vars_emem hs2. + have /= -> := write_vars_memP hs2. + by apply (sem_stack_stable_sprog hsem2). by apply (sem_validw_stable_sprog hsem2). have hresults''' := free_stack_spec_wf_results hargs hvalideq2 hfss hnnone hresults''. @@ -2826,6 +2812,8 @@ End INIT. Section HSAPARAMS. Context + {wsw : WithSubWord} + {dc : DirectCall} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} diff --git a/proofs/compiler/tunneling_proof.v b/proofs/compiler/tunneling_proof.v index df85c5132..28d740c1a 100644 --- a/proofs/compiler/tunneling_proof.v +++ b/proofs/compiler/tunneling_proof.v @@ -20,6 +20,7 @@ Require Import linear_sem. Section WITH_PARAMS. Context + {wsw : WithSubWord} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} @@ -1099,7 +1100,7 @@ Section TunnelingSem. case: encode_label => // wl; apply bind_eq => // m. by rewrite eval_jump_tunnel_lprog_pc. rewrite tunnel_get_label_after_pc. - apply bind_eq => // u; apply bind_eq => // l. + apply bind_eq => // u. apply bind_eq => // vm. case: encode_label => // wl; apply bind_eq => // m. by rewrite eval_jump_tunnel_lprog_pc. + rewrite /eval_instr /= label_in_lprog_tunnel_lprog_pc //. diff --git a/proofs/compiler/unrolling_proof.v b/proofs/compiler/unrolling_proof.v index 4ae456198..63f5ce25c 100644 --- a/proofs/compiler/unrolling_proof.v +++ b/proofs/compiler/unrolling_proof.v @@ -7,12 +7,13 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope vmap_scope. Local Open Scope seq_scope. Section PROOF. Context + {wsw : WithSubWord} + {dc:DirectCall} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} @@ -155,7 +156,7 @@ Section PROOF. Qed. Lemma write_var_Z i (z: Z) s s' : - write_var i z s = ok s' -> + write_var true i z s = ok s' -> vtype i = sint. Proof. by case: i => - [[] x]. Qed. diff --git a/proofs/compiler/x86_lowering_proof.v b/proofs/compiler/x86_lowering_proof.v index 336ba4130..69694d9e3 100644 --- a/proofs/compiler/x86_lowering_proof.v +++ b/proofs/compiler/x86_lowering_proof.v @@ -21,11 +21,12 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope vmap_scope. Local Open Scope seq_scope. Section PROOF. Context + {wsw : WithSubWord} + {dc : DirectCall} {atoI : arch_toIdent} {syscall_state : Type} {sc_sem : syscall_sem syscall_state} {T:eqType} {pT:progT T} {sCP: semCallParams}. @@ -159,15 +160,9 @@ Section PROOF. Proof. move=> ii i s1 s2 _ Hi; exact: Hi. Qed. Lemma type_of_get_gvar vm sz vn vi vs v: - get_gvar gd vm {| gv := {| v_var := {| vtype := sword sz; vname := vn |} ; v_info := vi |} ; gs := vs |} = ok v -> + get_gvar true gd vm {| gv := {| v_var := {| vtype := sword sz; vname := vn |} ; v_info := vi |} ; gs := vs |} = ok v -> ∃ sz', type_of_val v = sword sz' ∧ (sz' ≤ sz)%CMP. - Proof. - rewrite /get_gvar; case: vs => /=; last first. - - by case/get_globalI => gv [] _ -> ->; exists sz. - rewrite /get_var /on_vu. - case Heq: (vm.[_])=> [a|[]] // [<-] /=; eauto. - case: a {Heq} => /= sz' _; eauto. - Qed. + Proof. by move=> /type_of_get_gvar_sub /= /subtypeE. Qed. Lemma add_inc_dec_classifyP' sz a b: match add_inc_dec_classify sz a b with @@ -186,10 +181,10 @@ Section PROOF. Qed. Lemma add_inc_dec_classifyP s sz (a b : pexpr) w1 (z1: word w1) w2 (z2 : word w2) : - sem_pexprs gd s [:: a; b] = ok [:: Vword z1; Vword z2] -> + sem_pexprs true gd s [:: a; b] = ok [:: Vword z1; Vword z2] -> match add_inc_dec_classify sz a b with - | AddInc y => exists sz' (w: word sz'), (sz' = w1 ∨ sz' = w2) ∧ sem_pexpr gd s y = ok (Vword w) /\ zero_extend sz w + 1 = zero_extend sz z1 + zero_extend sz z2 - | AddDec y => exists sz' (w: word sz'), (sz' = w1 ∨ sz' = w2) ∧ sem_pexpr gd s y = ok (Vword w) /\ zero_extend sz w - 1 = zero_extend sz z1 + zero_extend sz z2 + | AddInc y => exists sz' (w: word sz'), (sz' = w1 ∨ sz' = w2) ∧ sem_pexpr true gd s y = ok (Vword w) /\ zero_extend sz w + 1 = zero_extend sz z1 + zero_extend sz z2 + | AddDec y => exists sz' (w: word sz'), (sz' = w1 ∨ sz' = w2) ∧ sem_pexpr true gd s y = ok (Vword w) /\ zero_extend sz w - 1 = zero_extend sz z1 + zero_extend sz z2 | AddNone => True end%R. Proof. @@ -215,7 +210,7 @@ Section PROOF. Lemma write_lval_word l sz v s s': stype_of_lval l = sword sz → - write_lval gd l v s = ok s' → + write_lval true gd l v s = ok s' → ∃ sz', type_of_val v = sword sz'. Proof. case: l => /= [ _ [] // sz' | [[vt vn] vi] | sz' [[vt vn] vi] e | aa sz' [[vt vn] vi] e | aa sz' len [[vt vn] vi] e ] /=. @@ -262,9 +257,9 @@ Section PROOF. Lemma lower_condition_corr ii ii' i e e' s1 cond: (i, e') = lower_condition fv ii' e -> forall s1', eq_exc_fresh s1' s1 -> - sem_pexpr gd s1' e = ok cond -> + sem_pexpr true gd s1' e = ok cond -> exists s2', - sem p' ev s1' (map (MkI ii) i) s2' /\ eq_exc_fresh s2' s1 /\ sem_pexpr gd s2' e' = ok cond. + sem p' ev s1' (map (MkI ii) i) s2' /\ eq_exc_fresh s2' s1 /\ sem_pexpr true gd s2' e' = ok cond. Proof. move=> Hcond s1' Hs1' He. move: Hcond. @@ -282,30 +277,30 @@ Section PROOF. have hw : forall (bof bcf bsf bpf bzf: bool), exists s2', [/\ - write_lvals gd s1' [:: Lvar Of; Lvar Cf; Lvar Sf; Lnone ii' sbool; Lvar Zf] + write_lvals true gd s1' [:: Lvar Of; Lvar Cf; Lvar Sf; Lnone ii' sbool; Lvar Zf] [:: Vbool bof; Vbool bcf; Vbool bsf; Vbool bpf; Vbool bzf] = ok s2', eq_exc_fresh s1' s2' & - [/\ sem_pexpr gd s2' (Plvar Of) = ok (Vbool bof), - sem_pexpr gd s2' (Plvar Cf) = ok (Vbool bcf), - sem_pexpr gd s2' (Plvar Sf) = ok (Vbool bsf) & - sem_pexpr gd s2' (Plvar Zf) = ok (Vbool bzf) ]]. + [/\ sem_pexpr true gd s2' (Plvar Of) = ok (Vbool bof), + sem_pexpr true gd s2' (Plvar Cf) = ok (Vbool bcf), + sem_pexpr true gd s2' (Plvar Sf) = ok (Vbool bsf) & + sem_pexpr true gd s2' (Plvar Zf) = ok (Vbool bzf) ]]. + eexists; split => /=; first reflexivity. + split. + by rewrite !escs_with_vm. + by rewrite !emem_with_vm. rewrite evm_with_vm => z hz. - by rewrite !Fv.setP_neq //; apply/eqP => heq; subst z; elim hz; + by rewrite !Vm.setP_neq //; apply/eqP => heq; subst z; elim hz; auto using of_in_fv, cf_in_fv, sf_in_fv. split=> /=. + rewrite get_gvar_neq; last by move => _; apply nesym; apply/eqP; exact: of_neq_zf. rewrite get_gvar_neq; last by move => _; apply nesym; apply/eqP; exact: of_neq_sf. rewrite get_gvar_neq; last by move => _; apply nesym; apply/eqP; exact: of_neq_cf. - by rewrite (@get_gvar_eq gd (mk_lvar Of)). + by rewrite (@get_gvar_eq _ _ gd (mk_lvar Of)). + rewrite get_gvar_neq; last by move => _; apply nesym; apply/eqP; exact: cf_neq_zf. rewrite get_gvar_neq; last by move => _; apply nesym; apply/eqP; exact: cf_neq_sf. - by rewrite (@get_gvar_eq gd (mk_lvar Cf)). + by rewrite (@get_gvar_eq _ _ gd (mk_lvar Cf)). + rewrite get_gvar_neq; last by move => _; apply nesym; apply/eqP; exact: sf_neq_zf. - by rewrite (@get_gvar_eq gd (mk_lvar Sf)). - by rewrite (@get_gvar_eq gd (mk_lvar Zf)). + by rewrite (@get_gvar_eq _ _ gd (mk_lvar Sf)). + by rewrite (@get_gvar_eq _ _ gd (mk_lvar Zf)). have {hw}hw : forall wx wy, to_word ws v2 = ok wy -> to_word ws v1 = ok wx -> @@ -313,10 +308,10 @@ Section PROOF. [/\ sem p' ev s1' [:: MkI ii (Copn [:: Lvar Of; Lvar Cf; Lvar Sf; Lnone ii' sbool; Lvar Zf] AT_none (Ox86 (CMP ws)) [:: e1; e2])] s2', eq_exc_fresh s2' s1 & - [/\ sem_pexpr gd s2' (Plvar Of) = ok (Vbool ((wsigned (wx - wy) != (wsigned wx - wsigned wy)%Z))), - sem_pexpr gd s2' (Plvar Cf) = ok (Vbool (wunsigned (wx - wy) != (wunsigned wx - wunsigned wy)%Z)), - sem_pexpr gd s2' (Plvar Sf) = ok (Vbool (SF_of_word (wx - wy))) & - sem_pexpr gd s2' (Plvar Zf) = ok (Vbool (ZF_of_word (wx - wy)))]]. + [/\ sem_pexpr true gd s2' (Plvar Of) = ok (Vbool ((wsigned (wx - wy) != (wsigned wx - wsigned wy)%Z))), + sem_pexpr true gd s2' (Plvar Cf) = ok (Vbool (wunsigned (wx - wy) != (wunsigned wx - wunsigned wy)%Z)), + sem_pexpr true gd s2' (Plvar Sf) = ok (Vbool (SF_of_word (wx - wy))) & + sem_pexpr true gd s2' (Plvar Zf) = ok (Vbool (ZF_of_word (wx - wy)))]]. + move=> wx wy hx hy; have [s2' [{hw}hw heq he]] := hw (wsigned (wx - wy) != (wsigned wx - wsigned wy)%Z) (wunsigned (wx - wy) != (wunsigned wx - wunsigned wy)%Z) @@ -432,28 +427,28 @@ Section PROOF. Proof. by move=> h; rewrite /check_size_128_256 h wsize_ge_U256. Qed. Lemma mulr_ok l sz w1 w2 (z1 : word w1) (z2:word w2) e1 e2 o e' s s': - sem_pexpr gd s e1 = ok (Vword z1) -> - sem_pexpr gd s e2 = ok (Vword z2) -> + sem_pexpr true gd s e1 = ok (Vword z1) -> + sem_pexpr true gd s e2 = ok (Vword z2) -> (sz ≤ w1)%CMP -> (sz ≤ w2)%CMP -> (U16 ≤ sz)%CMP && (sz ≤ U64)%CMP -> - write_lval gd l (Vword (zero_extend sz z1 * zero_extend sz z2)) s = ok s'-> + write_lval true gd l (Vword (zero_extend sz z1 * zero_extend sz z2)) s = ok s'-> mulr sz e1 e2 = (o, e') -> Sv.Subset (read_es e') (read_e (Papp2 (Omul (Op_w sz )) e1 e2)) - ∧ Let x := Let x := sem_pexprs gd s e' in exec_sopn (Ox86 o) x - in write_lvals gd s + ∧ Let x := Let x := sem_pexprs true gd s e' in exec_sopn (Ox86 o) x + in write_lvals true gd s [:: Lnone (var_info_of_lval l) sbool; Lnone (var_info_of_lval l) sbool; Lnone (var_info_of_lval l) sbool; Lnone (var_info_of_lval l) sbool; Lnone (var_info_of_lval l) sbool; l] x = ok s'. Proof. rewrite /mulr => ok_v1 ok_v2 hle1 hle2 hsz64 Hw. case Heq: (is_wconst _ _) => [z | ]. - * have! := (is_wconstP gd s Heq); t_xrbindP => v1 h1 hz [<- <-]. + * have! := (is_wconstP true gd s Heq); t_xrbindP => v1 h1 hz [<- <-]. split; first done. rewrite /= ok_v1 ok_v2 /= /exec_sopn /sopn_sem /= !truncate_word_le // {hle1 hle2}. by rewrite /x86_IMULt /check_size_16_64 hsz64 /= GRing.mulrC Hw. case Heq2: (is_wconst _ _) => [z | ]. - * have! := (is_wconstP gd s Heq2); t_xrbindP => v2 h2 hz [<- <-]. + * have! := (is_wconstP true gd s Heq2); t_xrbindP => v2 h2 hz [<- <-]. split; first by rewrite read_es_swap. rewrite /= ok_v1 ok_v2 /= /exec_sopn /sopn_sem /= !truncate_word_le // {hle1 hle2} /=. by rewrite /x86_IMULt /check_size_16_64 hsz64 /= Hw. @@ -474,16 +469,16 @@ Section PROOF. Lemma check_shift_amountP sz e sa s z w : check_shift_amount sz e = Some sa → - sem_pexpr gd s e = ok z → + sem_pexpr true gd s e = ok z → to_word U8 z = ok w → Sv.Subset (read_e sa) (read_e e) ∧ - exists2 n, sem_pexpr gd s sa >>= to_word U8 = ok n & ∀ f (a: word sz), sem_shift f a w = sem_shift f a (wand n (x86_shift_mask sz)). + exists2 n, sem_pexpr true gd s sa >>= to_word U8 = ok n & ∀ f (a: word sz), sem_shift f a w = sem_shift f a (wand n (x86_shift_mask sz)). Proof. rewrite /check_shift_amount. case en: is_wconst => [ n | ]. - case: eqP; last by []. move => n_in_range /Some_inj <-{sa} ok_z ok_w. - have! := (is_wconstP gd s en). + have! := (is_wconstP true gd s en). rewrite {en} ok_z /= ok_w => /ok_inj ?; subst w. split; first by []. exists n; first reflexivity. @@ -493,7 +488,7 @@ Section PROOF. case: eqP; last by []. move => ? /Some_inj ? /=; subst a n. rewrite /sem_sop2 /=; t_xrbindP => a ok_a c ok_c wa ok_wa wb ok_wb <-{z} /truncate_wordP[] _ ->{w}. - have! := (is_wconstP gd s en). + have! := (is_wconstP true gd s en). rewrite {en} ok_a ok_c /= => hc. split. - clear; rewrite {2}/read_e /= !read_eE; SvD.fsetdec. @@ -504,29 +499,29 @@ Section PROOF. by rewrite wand_zero_extend; last exact: wsize_le_U8. Qed. - Lemma lower_cassgn_classifyP e l s s' v ty v' (Hs: sem_pexpr gd s e = ok v) + Lemma lower_cassgn_classifyP e l s s' v ty v' (Hs: sem_pexpr true gd s e = ok v) (Hv': truncate_val ty v = ok v') - (Hw: write_lval gd l v' s = ok s'): + (Hw: write_lval true gd l v' s = ok s'): match lower_cassgn_classify ty e l with | LowerMov _ => exists2 sz, ty = sword sz & (sz ≤ U64)%CMP ∧ ∃ sz' (w : word sz'), (sz ≤ sz')%CMP ∧ v = Vword w | LowerCopn o a => - sem_pexprs gd s a >>= exec_sopn o = ok [:: v' ] + sem_pexprs true gd s a >>= exec_sopn o = ok [:: v' ] | LowerInc o a => - ∃ b1 b2 b3 b4, sem_pexprs gd s [:: a] >>= exec_sopn o = ok [:: Vbool b1; Vbool b2; Vbool b3; Vbool b4; v'] + ∃ b1 b2 b3 b4, sem_pexprs true gd s [:: a] >>= exec_sopn o = ok [:: Vbool b1; Vbool b2; Vbool b3; Vbool b4; v'] | LowerFopn _ o e' _ => let vi := var_info_of_lval l in let f := Lnone vi sbool in Sv.Subset (read_es e') (read_e e) ∧ - sem_pexprs gd s e' >>= exec_sopn o >>= - write_lvals gd s [:: f; f; f; f; f; l] = ok s' + sem_pexprs true gd s e' >>= exec_sopn o >>= + write_lvals true gd s [:: f; f; f; f; f; l] = ok s' | LowerDiscardFlags n op e' => let f := Lnone (var_info_of_lval l) sbool in Sv.Subset (read_es e') (read_e e) - /\ sem_pexprs gd s e' + /\ sem_pexprs true gd s e' >>= exec_sopn op - >>= write_lvals gd s (nseq n f ++ [:: l ]) = ok s' + >>= write_lvals true gd s (nseq n f ++ [:: l ]) = ok s' | LowerDivMod p u sz o a b => let vi := var_info_of_lval l in let f := Lnone vi sbool in @@ -536,20 +531,20 @@ Section PROOF. | DM_Snd => [:: f; f; f; f; f; Lnone vi (sword sz); l] end in [/\ (exists (va:value)(wa:word sz), - [/\ (sem_pexpr gd s a) = ok va, + [/\ (sem_pexpr true gd s a) = ok va, to_word sz va = ok wa & (forall s1, eq_exc_fresh s1 s -> disj_fvars (vars_lval l) -> disj_fvars (read_e e) -> - [/\ (sem_pexpr gd s1 a) = ok va & + [/\ (sem_pexpr true gd s1 a) = ok va & exists s1', - (Let vb := (sem_pexpr gd s1 b) in + (Let vb := (sem_pexpr true gd s1 b) in let v0 : word sz := if u is Unsigned then 0%R else if msb wa then (-1)%R else 0%R in exec_sopn o [::Vword v0; va; vb] >>= - write_lvals gd s1 lv) = ok s1' /\ + write_lvals true gd s1 lv) = ok s1' /\ eq_exc_fresh s1' s'])]), ty = sword sz , (U16 ≤ sz)%CMP & (sz ≤ U64)%CMP] | LowerCond => True @@ -561,7 +556,7 @@ Section PROOF. exists w: word sz, v' = Vword w /\ sem_lea sz (evm s) l = ok w) | LowerConcat hi lo => - sem_pexprs gd s [:: hi ; lo ] >>= exec_sopn (Oasm (ExtOp Oconcat128)) = ok [:: v' ] + sem_pexprs true gd s [:: hi ; lo ] >>= exec_sopn (Oasm (ExtOp Oconcat128)) = ok [:: v' ] | LowerAssgn => True end. Proof. @@ -773,13 +768,13 @@ Section PROOF. /check_size_16_64 /= hsz1 hsz2 /= hw2 /=. + rewrite hw1 /= wdwords0 (wsigned_quot_bound neq hdiv) /=. move: Hw; rewrite /wdivi => /(eeq_exc_write_lval hl hs1) [s1' -> ?]. - by exists s1'. + by exists s1'; split => //=; rewrite /write_none /= cmp_le_refl orbT. have hw2' : (wunsigned w2 == 0%Z) = false. + by apply /negbTE; apply /eqP => h; apply neq, wunsigned_inj. rewrite hw2' hw1 /= wdwordu0. move: hw2' => /negbT -/(wunsigned_div_bound w1) -/negbTE -> /=. move: Hw; rewrite /wdivi => /(eeq_exc_write_lval hl hs1) [s1' -> ?]. - by exists s1'. + by exists s1'; split => //=; rewrite /write_none /= cmp_le_refl orbT. (* Omod (Cmp_w u sz) *) + case: ifP => // /andP [] /andP [] hsz1 hsz2 /eqP ?; subst ty. @@ -802,19 +797,21 @@ Section PROOF. rewrite /= /exec_sopn /sopn_sem /= /x86_IDIV /x86_DIV !truncate_word_u /check_size_16_64 /= hsz1 hsz2 /= hw2 /=. + rewrite hw1 /= wdwords0 (wsigned_quot_bound neq hdiv) /=. - move: Hw; rewrite /wdivi => /(eeq_exc_write_lval hl hs1) [s1' -> ?]. + rewrite /write_none /= cmp_le_refl orbT /=. + move: Hw;rewrite /wdivi => /(eeq_exc_write_lval hl hs1) [s1' -> ?]. by exists s1'. have hw2' : (wunsigned w2 == 0%Z) = false. + by apply /negbTE; apply /eqP => h; apply neq, wunsigned_inj. rewrite hw2' hw1 /= wdwordu0. move: hw2' => /negbT -/(wunsigned_div_bound w1) -/negbTE -> /=. + rewrite /write_none /= cmp_le_refl orbT /=. move: Hw; rewrite /wdivi => /(eeq_exc_write_lval hl hs1) [s1' -> ?]. by exists s1'. (* Oland Op_w *) + case handn : is_andn => [[a1 a2] | ]. + move=> he. - have : sem_pexpr gd s (Papp2 (Oland sz) (Papp1 (Olnot sz) a1) a2) = ok v /\ + have : sem_pexpr true gd s (Papp2 (Oland sz) (Papp1 (Olnot sz) a1) a2) = ok v /\ Sv.Subset (read_es [:: a1; a2]) (read_e (Papp2 (Oland sz) e1 e2)). + have hlnot : forall e, match is_lnot e with | Some a => exists sz, e = Papp1 (Olnot sz) a @@ -1064,14 +1061,10 @@ Section PROOF. Qed. Lemma vmap_eq_except_set q s x v: - Sv.In x q → s.[ x <- v] = s [\q]. - Proof. - move=> h a ha. apply: Fv.setP_neq. - by case: eqP => // ?; subst. - Qed. + Sv.In x q → s.[ x <- v] =[\q] s. + Proof. by move=> h; apply eq_ex_set_l => // /(_ h). Qed. - Definition pwrepr64 n := - {| pw_size := U64 ; pw_word := wrepr _ n ; pw_proof := erefl (U64 ≤ U64)%CMP |}. + Definition pwrepr64 n := wrepr U64 n. Lemma opn_no_immP (P: sopn → sopn → Prop) : (∀ ws sz, P (Oasm (BaseOp (ws, IMULri sz))) (Oasm (BaseOp (ws, IMULr sz)))) → @@ -1102,9 +1095,9 @@ Section PROOF. Lemma opn_5flags_correct vi ii s a t o cf r xs ys m sz s' : disj_fvars (read_es a) → disj_fvars (vars_lvals [:: cf ; r ]) → - sem_pexprs gd s a = ok xs → + sem_pexprs true gd s a = ok xs → exec_sopn o xs = ok ys → - write_lvals gd s [:: Lnone_b vi ; cf ; Lnone_b vi ; Lnone_b vi ; Lnone_b vi ; r] ys = ok s' → + write_lvals true gd s [:: Lnone_b vi ; cf ; Lnone_b vi ; Lnone_b vi ; Lnone_b vi ; r] ys = ok s' → ∃ s'', sem p' ev s [seq MkI ii i | i <- opn_5flags fv m sz vi cf r t o a] s'' ∧ eq_exc_fresh s'' s'. @@ -1116,7 +1109,7 @@ Section PROOF. set wtmp := {| v_var := _ |}. set ℓ := with_vm s - (evm s).[wtmp <- ok (pwrepr64 n)]. + (evm s).[wtmp <- Vword (pwrepr64 n)]. assert (eq_exc_fresh ℓ s) as e. + subst ℓ; case:(s) => ?? /=;split => //. by apply vmap_eq_except_set, multiplicand_in_fv. @@ -1127,14 +1120,13 @@ Section PROOF. case: dxz => dx dz. case:(eeq_exc_write_lvals _ e hs). exact dr. move=> s'' hs' e'. - exists s''. refine (conj _ e'). - rewrite -cat1s; apply: sem_app; apply: sem_seq1; constructor; constructor. - + by rewrite /sem_sopn /= /exec_sopn /= truncate_word_u /= -/(pwrepr64 _) -/ℓ. + exists s''. refine (conj _ e'). repeat econstructor. + + by rewrite /sem_sopn /= /= /exec_sopn /= truncate_word_u /= -/(pwrepr64 _) write_var_eq_type. + rewrite /sem_sopn /= -/ℓ. move: hx; rewrite /sem_pexprs /=; t_xrbindP => y hy z' z1 hz1 ? ?; subst z' xs. - rewrite /sem_sopn /= (eeq_exc_sem_pexpr dx e hy) /=. - fold (sem_pexprs gd s) in hz1. - rewrite /get_gvar /get_var /on_vu Fv.setP_eq /= -/(sem_pexprs gd ℓ). - + rewrite (eeq_exc_sem_pexpr dx e hy) /=. + fold (sem_pexprs true gd s) in hz1. + rewrite /get_gvar get_var_eq /= cmp_le_refl orbT -/(sem_pexprs true gd ℓ) //. rewrite (eeq_exc_sem_pexprs dz e hz1) /= /exec_sopn /sopn_sem /=. move: hr. apply opn_no_immP. @@ -1160,9 +1152,9 @@ Section PROOF. Qed. Lemma reduce_wconstP s e sz sz' (v: word sz') : - sem_pexpr gd s e = ok (Vword v) → + sem_pexpr true gd s e = ok (Vword v) → ∃ sw (w: word sw), - sem_pexpr gd s (reduce_wconst sz e) = ok (Vword w) ∧ + sem_pexpr true gd s (reduce_wconst sz e) = ok (Vword w) ∧ (cmp_min sz sz' ≤ sw)%CMP ∧ zero_extend sz v = zero_extend sz w. Proof. @@ -1179,8 +1171,8 @@ Section PROOF. Lemma mov_wsP (p1: prog) s1 e ws tag i x w s2 : (ws <= U64)%CMP -> - (Let i' := sem_pexpr (p_globs p1) s1 e in to_word ws i') = ok i - -> write_lval (p_globs p1) x (Vword i) s1 = ok s2 + (Let i' := sem_pexpr true (p_globs p1) s1 e in to_word ws i') = ok i + -> write_lval true (p_globs p1) x (Vword i) s1 = ok s2 -> sem_i p1 w s1 (mov_ws ws x e tag) s2. Proof. by move=> hws he hx; rewrite /mov_ws; case: ifP => [ /andP [] _ h | _]; @@ -1207,16 +1199,17 @@ Section PROOF. * set wtmp := {| v_var := _ |}. set ℓ := with_vm s1' - (evm s1').[ wtmp <- ok (pword_of_word (zero_extend tw vw)) ]. + (evm s1').[ wtmp <- Vword (zero_extend tw vw) ]. assert (eq_exc_fresh ℓ s1') as dℓ. + subst ℓ; case:(s1') => ?? /=; split => //. by apply vmap_eq_except_set, multiplicand_in_fv. case: (eeq_exc_write_lval Hdisjl dℓ Hw') => ℓ' hℓ' dℓ'. eexists; split. repeat econstructor. - by rewrite /sem_sopn /sem_pexprs /= h /= /exec_sopn /sopn_sem /= truncate_word_le // {hsz} - /x86_MOV /check_size_8_64 hle' /= /write_var /set_var /= sumbool_of_boolET. - by rewrite /sem_sopn /sem_pexprs/= /get_gvar /get_var Fv.setP_eq /= /exec_sopn /sopn_sem /= truncate_word_u /x86_MOV /check_size_8_64 hle' /= -/ℓ -hw hℓ'. + + by rewrite /sem_sopn /sem_pexprs /= h /= /exec_sopn /sopn_sem /= truncate_word_le // {hsz} + /x86_MOV /check_size_8_64 hle' /= write_var_eq_type. + rewrite /sem_sopn /sem_pexprs/= /get_gvar get_var_eq /= cmp_le_refl orbT //. + by rewrite /exec_sopn /sopn_sem /= truncate_word_u /x86_MOV /check_size_8_64 hle' /= -/ℓ -hw hℓ'. exact: (eeq_excT dℓ' Hs2'). * exists s2'; split=> //=. case: ifP => [/andP [] /andP [] /is_zeroP he ??| _ ];first last. @@ -1241,8 +1234,8 @@ Section PROOF. set ob := oapp Plvar _ b; set oo := oapp Plvar _ o. have [wb [wo [Hwb Hwo Ew ]]]: exists (wb wo: word sz), - [/\ sem_pexpr gd s1' ob >>= to_word sz = ok wb, - sem_pexpr gd s1' oo >>= to_word sz = ok wo & + [/\ sem_pexpr true gd s1' ob >>= to_word sz = ok wb, + sem_pexpr true gd s1' oo >>= to_word sz = ok wo & w = (wrepr sz d + (wb + (wrepr sz sc * wo)))%R]. + move: Hslea; rewrite /sem_lea /=; t_xrbindP => wb Hwb wo Hwo H. exists wb, wo; split. @@ -1258,7 +1251,7 @@ Section PROOF. set elea := Papp2 (Oadd (Op_w sz)) (wconst (wrepr Uptr d)) (Papp2 (Oadd (Op_w sz)) ob (Papp2 (Omul (Op_w sz)) (wconst (wrepr Uptr sc)) oo)). case /andP: hsz => hsz1 hsz2. have Hlea : - Let vs := sem_pexprs gd s1' [:: elea ] in + Let vs := sem_pexprs true gd s1' [:: elea ] in exec_sopn (Ox86 (LEA sz)) vs = ok [:: Vword w ]. + rewrite /sem_pexprs /= Hvb Hvo /= /exec_sopn /sopn_sem /sem_sop2 /= !truncate_word_le // /=. rewrite Hwb Hwo /= truncate_word_u /= truncate_word_u /= truncate_word_u /= /x86_LEA /check_size_16_64 hsz1 hsz2 /=. @@ -1277,7 +1270,7 @@ Section PROOF. case Heq : mulr => [o1 e']. move: Hvb; rewrite Eob /= /sem_sop1 /= => -[?]; subst vb. have [sz1 [w1 [hle1 ??]]]:= to_wordI' Hwo;subst vo wo. - have Hsc1 : sem_pexpr gd s1' (wconst (wrepr Uptr sc)) = ok (Vword (wrepr Uptr sc)). + have Hsc1 : sem_pexpr true gd s1' (wconst (wrepr Uptr sc)) = ok (Vword (wrepr Uptr sc)). + by rewrite /wconst /= /sem_sop1 /= wrepr_unsigned. move: Hwb; rewrite /= truncate_word_u wrepr_unsigned => -[?];subst wb. rewrite wrepr0 !GRing.add0r GRing.mulrC in Hw'. @@ -1314,23 +1307,24 @@ Section PROOF. set wtmp := {| v_var := _ |}. set si := with_vm s1' - (evm s1').[ wtmp <- ok (pwrepr64 d) ]. + (evm s1').[ wtmp <- Vword (wrepr U64 d)]. have hsi : eq_exc_fresh si s1'. - + by rewrite /si; case: (s1') => ?? /=; split => //= k hk; rewrite Fv.setP_neq //; apply/eqP => ?; subst k; apply: hk; exact: multiplicand_in_fv. + + by rewrite /si; case: (s1') => ?? /=; split => //= k hk; rewrite Vm.setP_neq //; apply/eqP => ?; subst k; apply: hk; exact: multiplicand_in_fv. have [si' Hwi hsi'] := eeq_exc_write_lval Hdisjl hsi Hw'. eexists; split. - + rewrite -cat1s; apply: sem_app; apply: sem_seq1; constructor; constructor. - * by rewrite /sem_sopn /exec_sopn /= truncate_word_u /= wrepr_unsigned -/(pwrepr64 _). + + apply: Eseq. + + by repeat constructor; rewrite /sem_sopn /exec_sopn /= truncate_word_u /= wrepr_unsigned -/(pwrepr64 _) write_var_eq_type. + apply: sem_seq1. repeat constructor. rewrite /sem_sopn /exec_sopn /sopn_sem /=. - rewrite /get_gvar /get_var Fv.setP_eq /=. - rewrite (eeq_exc_sem_pexpr (xs := fvars) _ _ Hvb) //=. - - by rewrite Hwb /= truncate_word_le // /x86_ADD /check_size_8_64 hsz2 /= zero_extend_wrepr // Hwi. - apply: (disj_fvars_subset _ Hdisje). - apply: (SvD.F.Subset_trans _ hrl). - rewrite /read_lea /=; subst ob; case: (b) => [ x | ] /=. - - SvD.fsetdec. - exact: SvP.MP.subset_empty. - exact: (eeq_excT hsi' Hs2'). + rewrite /get_gvar get_var_eq //= cmp_le_refl orbT //=. + rewrite (eeq_exc_sem_pexpr (xs := fvars) _ _ Hvb) //=. + - by rewrite Hwb /= truncate_word_le //= /x86_ADD /check_size_8_64 hsz2 /= zero_extend_wrepr // Hwi. + apply: (disj_fvars_subset _ Hdisje). + apply: (SvD.F.Subset_trans _ hrl). + rewrite /read_lea /=; subst ob; case: (b) => [ x | ] /=. + - SvD.fsetdec. + exact: SvP.MP.subset_empty. + exact: (eeq_excT hsi' Hs2'). (* LowerFopn *) + set vi := var_info_of_lval _. @@ -1408,17 +1402,17 @@ Section PROOF. move: hdiv; set va0 := Vword (match u with Signed => _ | _ => _ end) => hdiv. have [s1'1 [hsem1 hget heq1]]: exists s1'1, [/\ sem_I p' ev s1' (MkI ii i1) s1'1, - get_var (evm s1'1) (v_var vf) = ok va0 & + get_var true (evm s1'1) (v_var vf) = ok va0 & eq_exc_fresh s1'1 s1']. + rewrite /i1 /va0; case: (u); eexists; split. - + by apply: EmkI; rewrite /i1; apply: Eopn; rewrite /sem_sopn /exec_sopn /sopn_sem /= hva /= hwa /x86_CQO /= - /check_size_16_64 hle1 hle2 /= sumbool_of_boolET;eauto. - + by rewrite /get_var Fv.setP_eq. + + apply: EmkI; rewrite /i1; apply: Eopn; rewrite /sem_sopn /exec_sopn /sopn_sem /= hva /= hwa /x86_CQO /= + /check_size_16_64 hle1 hle2 /= write_var_eq_type //. + + by rewrite get_var_eq //= cmp_le_refl orbT. + by split => //; apply vmap_eq_except_set; apply multiplicand_in_fv. + by apply: EmkI; apply: Eopn; rewrite /sem_sopn /exec_sopn /sopn_sem /= truncate_word_u /= - /x86_MOV /check_size_8_64 hle2 /=;eauto. - + by rewrite /= sumbool_of_boolET /get_var /= Fv.setP_eq /= wrepr0. - rewrite sumbool_of_boolET; split => //. + /x86_MOV /check_size_8_64 hle2 /= write_var_eq_type. + + by rewrite /= get_var_eq /= cmp_le_refl orbT ?wrepr0. + split => //. by apply vmap_eq_except_set; apply multiplicand_in_fv. have [hwa1 [s3 [hsem heqe] {hdiv}]]:= hdiv _ heq1 Hdisjl Hdisje. exists s3;split. @@ -1514,9 +1508,9 @@ Section PROOF. Qed. Lemma sem_pexprs_dec2 s e1 e2 v1 v2: - sem_pexprs gd s [:: e1; e2] = ok [:: v1; v2] -> - sem_pexpr gd s e1 = ok v1 /\ - sem_pexpr gd s e2 = ok v2. + sem_pexprs true gd s [:: e1; e2] = ok [:: v1; v2] -> + sem_pexpr true gd s e1 = ok v1 /\ + sem_pexpr true gd s e2 = ok v2. Proof. rewrite /sem_pexprs /=. t_xrbindP=> v1' -> [] // v1'' [] // v2' -> []<- <- []<-. @@ -1524,10 +1518,10 @@ Section PROOF. Qed. Lemma sem_pexprs_dec3 s e1 e2 e3 v1 v2 v3: - sem_pexprs gd s [:: e1; e2; e3] = ok [:: v1; v2; v3] -> - sem_pexpr gd s e1 = ok v1 /\ - sem_pexpr gd s e2 = ok v2 /\ - sem_pexpr gd s e3 = ok v3. + sem_pexprs true gd s [:: e1; e2; e3] = ok [:: v1; v2; v3] -> + sem_pexpr true gd s e1 = ok v1 /\ + sem_pexpr true gd s e2 = ok v2 /\ + sem_pexpr true gd s e3 = ok v3. Proof. rewrite /sem_pexprs /=. t_xrbindP=> v1' -> [] // v2' [] // v3' [] // v4' Hv4' [] // v5' [] // v6' Hv6' []<- []<- <- <- []<- <-. @@ -1535,7 +1529,7 @@ Section PROOF. Qed. Lemma write_lvals_dec2_s s1 s2 v1 v2 xs: - write_lvals gd s1 xs [:: v1; v2] = ok s2 -> + write_lvals true gd s1 xs [:: v1; v2] = ok s2 -> exists x1 x2, xs = [:: x1; x2]. Proof. move: xs=> [] // x1 [] //=. @@ -1547,7 +1541,7 @@ Section PROOF. Qed. Lemma sem_pexprs_dec2_s s es v1 v2: - sem_pexprs gd s es = ok [:: v1; v2] -> + sem_pexprs true gd s es = ok [:: v1; v2] -> exists e1 e2, es = [:: e1; e2]. Proof. move: es=> [] // e1 [] //. @@ -1582,10 +1576,10 @@ Section PROOF. eq_exc_fresh si' si → disj_fvars (vars_lvals xs) → disj_fvars (read_es es) → - sem_pexprs gd si' es = ok x → + sem_pexprs true gd si' es = ok x → let: op := if sub then sopn_subcarry else sopn_addcarry in exec_sopn (op sz) x = ok v → - write_lvals gd si' xs v = ok so → + write_lvals true gd si' xs v = ok so → ∃ so', sem p' ev si' (map (MkI ii) (lower_addcarry fv sz sub xs t es)) so' ∧ eq_exc_fresh so' so. @@ -1601,11 +1595,11 @@ Section PROOF. assert ( disj_fvars (read_es es') ∧ ∃ x', - sem_pexprs gd si' es' = ok x' ∧ + sem_pexprs true gd si' es' = ok x' ∧ ∃ v', exec_sopn (Ox86 (op sz)) x' = ok v' ∧ let f := Lnone_b vi in - write_lvals gd si' [:: f ; cf ; f ; f ; f ; r ] v' = ok so) as D. + write_lvals true gd si' [:: f ; cf ; f ; f ; f ; r ] v' = ok so) as D. { clear - hsz64 des hx hv C ho. case: C => [ [? [? [? ?]]] | [cfi [?[?[? ?]]]]]; subst; apply (conj des). @@ -1659,16 +1653,16 @@ Section PROOF. by rewrite /sem_sopn /= /exec_sopn /sopn_sem /= He1 He2 /= !truncate_word_le. rewrite /lower_mulu; case hsz: check_size_16_64 => //. have /andP [hsz16 hsz64] := assertP hsz. - have! := (is_wconstP gd s1' (sz := sz) (e := e1)). + have! := (is_wconstP true gd s1' (sz := sz) (e := e1)). case: is_wconst => [ n1 | _ ]. + move => /(_ _ erefl) /=; rewrite He1 /= truncate_word_le // => - [?]; subst n1. set wtmp := {| v_var := _ |}. set s2'' := with_vm s1' - (evm s1').[ wtmp <- ok (pword_of_word (zero_extend _ w1)) ]. + (evm s1').[ wtmp <- Vword (zero_extend sz w1) ]. have Heq: eq_exc_fresh s2'' s1'. split=> //. rewrite /s2'' /= => x Hx. - rewrite Fv.setP_neq //. + rewrite Vm.setP_neq //. apply/eqP=> Habs; apply: Hx; rewrite -Habs //. have [s3'' Hw'' Hs3''] := eeq_exc_write_lvals Hdisjl Heq Hw'. have Hd2 : disj_fvars (read_e e2). @@ -1679,23 +1673,23 @@ Section PROOF. eexists; split. + apply: Eseq. + apply: EmkI; apply: Eopn; eauto. - rewrite /sem_sopn /sem_pexprs /= /exec_sopn /sopn_sem /= He1 /= truncate_word_le // /= /x86_MOV /check_size_8_64 hsz64 /=. - by rewrite sumbool_of_boolET. + by rewrite /sem_sopn /sem_pexprs /= /exec_sopn /sopn_sem /= He1 /= truncate_word_le // /= /x86_MOV /check_size_8_64 hsz64 /= write_var_eq_type. + apply: sem_seq1; apply: EmkI; apply: Eopn=> /=. rewrite /= /read_es /= in Hdisje. rewrite /sem_sopn /sem_pexprs /= He2' /=. - rewrite /get_gvar /get_var /on_vu /= Fv.setP_eq /= /exec_sopn /sopn_sem /= !truncate_word_le // {hsz2} /x86_MUL hsz /= zero_extend_u wmulhuE Z.mul_comm GRing.mulrC wmulE. + rewrite /get_gvar get_var_eq /= cmp_le_refl orbT //=. + rewrite /exec_sopn /sopn_sem /= !truncate_word_le // {hsz2} /x86_MUL hsz /= zero_extend_u wmulhuE Z.mul_comm GRing.mulrC wmulE. exact Hw''. + exact: (eeq_excT Hs3'' Hs2'). - have! := (is_wconstP gd s1' (sz := sz) (e := e2)). + have! := (is_wconstP true gd s1' (sz := sz) (e := e2)). case: is_wconst => [ n2 | _ ]. + move => /(_ _ erefl) /=; rewrite He2 /= truncate_word_le // => - [?]; subst n2. set wtmp := {| v_var := _ |}. - set s2'' := with_vm s1' (evm s1').[ wtmp <- ok (pword_of_word (zero_extend _ w2)) ]. + set s2'' := with_vm s1' (evm s1').[ wtmp <- Vword (zero_extend sz w2) ]. have Heq: eq_exc_fresh s2'' s1'. * split=> //. rewrite /s2'' /= => x Hx. - rewrite Fv.setP_neq //. + rewrite Vm.setP_neq //. apply/eqP=> Habs; apply: Hx; rewrite -Habs //. have [s3'' Hw'' Hs3''] := eeq_exc_write_lvals Hdisjl Heq Hw'. have Hd1 : disj_fvars (read_e e1). @@ -1705,11 +1699,12 @@ Section PROOF. + apply: Eseq. + apply: EmkI; apply: Eopn; eauto. rewrite /sem_sopn /sem_pexprs /= He2 /= /exec_sopn /sopn_sem /= !truncate_word_le // /= /x86_MOV /check_size_8_64 hsz64 /=. - by rewrite /write_var /set_var /= sumbool_of_boolET. + by rewrite write_var_eq_type. + apply: sem_seq1; apply: EmkI; apply: Eopn=> /=. rewrite /= /read_es /= in Hdisje. rewrite /sem_sopn /sem_pexprs /= He1' /=. - rewrite /get_gvar /get_var /on_vu /= Fv.setP_eq /= /exec_sopn /sopn_sem /= !truncate_word_le // /x86_MUL hsz /= zero_extend_u wmulhuE wmulE. + rewrite /get_gvar get_var_eq /= cmp_le_refl orbT //. + rewrite /exec_sopn /sopn_sem /= !truncate_word_le // /x86_MUL hsz /= zero_extend_u wmulhuE wmulE. exact: Hw''. + exact: (eeq_excT Hs3'' Hs2'). exists s2'; split=> //; apply: sem_seq1; apply: EmkI; apply: Eopn. @@ -1838,7 +1833,7 @@ Section PROOF. Proof. move=> s1 s1' s2 s3 i w ws c Hw _ Hc _ Hfor Hdisj s1'' Hs1''. have := Hdisj=> /disjoint_union [Hdisjc Hdisji]. - have Hw1: write_lval gd (Lvar i) w s1 = ok s1' by exact: Hw. + have Hw1: write_lval true gd (Lvar i) w s1 = ok s1' by exact: Hw. have [|s2'' Hs2''1 Hs2''2] := eeq_exc_write_lval _ Hs1'' Hw1. rewrite /=; have H: Sv.Equal (Sv.union Sv.empty (Sv.add i Sv.empty)) (Sv.singleton i). by SvD.fsetdec. @@ -1879,8 +1874,8 @@ Section PROOF. + exact: Hs1'1. + rewrite /=. have ->: vm1' = evm (with_vm s2 vm1') by rewrite evm_with_vm. - rewrite -(sem_pexprs_get_var gd). - rewrite -(sem_pexprs_get_var gd) in Hres. + rewrite -(sem_pexprs_get_var _ gd). + rewrite -(sem_pexprs_get_var _ gd) in Hres. have H': forall l, Sv.Equal (read_es (map Plvar l)) (vars_l l). + elim=> // a l /= Hl. diff --git a/proofs/compiler/x86_params_proof.v b/proofs/compiler/x86_params_proof.v index 80c1d0c2e..1a19671c1 100644 --- a/proofs/compiler/x86_params_proof.v +++ b/proofs/compiler/x86_params_proof.v @@ -41,6 +41,8 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. +#[local] Existing Instance withsubword. + Section Section. Context {atoI : arch_toIdent} {syscall_state : Type} {sc_sem : syscall_sem syscall_state}. @@ -48,11 +50,11 @@ Context {atoI : arch_toIdent} {syscall_state : Type} {sc_sem : syscall_sem sysca (* ------------------------------------------------------------------------ *) (* Flag combination hypotheses. *) -Lemma x86_cf_xsemP gd s e0 e1 e2 e3 cf v : +Lemma x86_cf_xsemP wdb gd s e0 e1 e2 e3 cf v : let e := PappN (Ocombine_flags cf) [:: e0; e1; e2; e3 ] in let e' := cf_xsem enot eand eor expr.eeq e0 e1 e2 e3 cf in - sem_pexpr gd s e = ok v - -> sem_pexpr gd s e' = ok v. + sem_pexpr wdb gd s e = ok v + -> sem_pexpr wdb gd s e' = ok v. Proof. rewrite /=. @@ -73,7 +75,7 @@ Proof. all: by rewrite ?hv0 ?hv1 ?hv2 ?hv3. Qed. -Definition x86_hpiparams : h_propagate_inline_params := +Definition x86_hpiparams {dc: DirectCall} : h_propagate_inline_params := {| pip_cf_xsemP := x86_cf_xsemP; |}. @@ -82,27 +84,26 @@ Definition x86_hpiparams : h_propagate_inline_params := (* Stack alloc hypotheses. *) Section STACK_ALLOC. +Context {dc : DirectCall} (is_regx : var -> bool) (P' : sprog). - Variable (P' : sprog). - - Lemma lea_ptrP s1 e i x tag ofs w s2 : - P'.(p_globs) = [::] - -> (Let i' := sem_pexpr [::] s1 e in to_pointer i') = ok i - -> write_lval [::] x (Vword (i + wrepr _ ofs)) s1 = ok s2 - -> psem.sem_i (pT := progStack) P' w s1 (lea_ptr x e tag ofs) s2. - Proof. - move=> P'_globs he hx. - constructor. - rewrite /sem_sopn /= P'_globs /sem_sop2 /=. - move: he; t_xrbindP=> _ -> /= -> /=. - by rewrite /exec_sopn truncate_word_u /= truncate_word_u /= hx. - Qed. +Lemma lea_ptrP s1 e i x tag ofs w s2 : + P'.(p_globs) = [::] + -> (Let i' := sem_pexpr true [::] s1 e in to_pointer i') = ok i + -> write_lval true [::] x (Vword (i + wrepr _ ofs)) s1 = ok s2 + -> psem.sem_i (pT := progStack) P' w s1 (lea_ptr x e tag ofs) s2. +Proof. + move=> P'_globs he hx. + constructor. + rewrite /sem_sopn /= P'_globs /sem_sop2 /=. + move: he; t_xrbindP=> _ -> /= -> /=. + by rewrite /exec_sopn truncate_word_u /= truncate_word_u /= hx. +Qed. Lemma x86_mov_ofsP s1 e i x tag ofs w vpk s2 ins : p_globs P' = [::] - -> (Let i' := sem_pexpr [::] s1 e in to_pointer i') = ok i + -> (Let i' := sem_pexpr true [::] s1 e in to_pointer i') = ok i -> sap_mov_ofs x86_saparams x tag vpk e ofs = Some ins - -> write_lval [::] x (Vword (i + wrepr Uptr ofs)) s1 = ok s2 + -> write_lval true [::] x (Vword (i + wrepr Uptr ofs)) s1 = ok s2 -> psem.sem_i (pT := progStack) P' w s1 ins s2. Proof. move=> P'_globs he. @@ -116,18 +117,18 @@ Qed. Lemma x86_immediateP w s (x: var_i) z : vtype x = sword Uptr - -> psem.sem_i (pT := progStack) P' w s (x86_immediate x z) (with_vm s (evm s).[x <- pof_val x.(vtype) (Vword (wrepr Uptr z))])%vmap. + -> psem.sem_i (pT := progStack) P' w s (x86_immediate x z) (with_vm s (evm s).[x <- Vword (wrepr Uptr z)]). Proof. case: x => - [] [] // [] // x xi _ /=. have := mov_wsP (pT := progStack) AT_none _ (cmp_le_refl _). - move => /(_ _ _ _ _ _ P'). + move => /(_ _ _ _ _ _ _ _ P'). apply; last reflexivity. by rewrite /= truncate_word_u. Qed. End STACK_ALLOC. -Definition x86_hsaparams : h_stack_alloc_params (ap_sap x86_params) := +Definition x86_hsaparams {dc : DirectCall} : h_stack_alloc_params (ap_sap x86_params) := {| mov_ofsP := x86_mov_ofsP; sap_immediateP := x86_immediateP; @@ -174,17 +175,17 @@ Definition x86_op_align_eval_instr |} in (ws <= U64)%CMP - -> get_var (lvm ls) (v_var x) = ok (Vword w) + -> get_var true (lvm ls) (v_var x) = ok (@Vword ws w) -> let: li := li_of_copn_args ii (x86_op_align x ws al) in let w' := align_word al w in let: vm' := (lvm ls) - .[to_var OF <- ok false] - .[to_var CF <- ok false] - .[to_var SF <- ok (SF_of_word w')] - .[to_var PF <- ok (PF_of_word w')] - .[to_var ZF <- ok (ZF_of_word w')] - .[v_var x <- ok (pword_of_word w')]%vmap + .[to_var OF <- false] + .[to_var CF <- false] + .[to_var SF <- (SF_of_word w')] + .[to_var PF <- (PF_of_word w')] + .[to_var ZF <- (ZF_of_word w')] + .[v_var x <- Vword w'] in let: ls' := {| @@ -210,12 +211,9 @@ Proof. rewrite /sopn_sem /=. rewrite /x86_AND /check_size_8_64. rewrite hws {hws} /=. - rewrite sumbool_of_boolET. - rewrite /with_vm /of_estate pword_of_wordE -/(align_word al w) /=. - by rewrite addn1. + by rewrite /with_vm /of_estate /= -/(align_word al w) /= addn1. Qed. - Context {call_conv : calling_convention} (lp : lprog) @@ -230,33 +228,31 @@ Let vtmpi : var_i := VarI vtmp dummy_var_info. Definition x86_spec_lip_allocate_stack_frame s pc ii ts sz : let: args := lip_allocate_stack_frame x86_liparams vrspi sz in let: i := MkLI ii (Lopn args.1.1 args.1.2 args.2) in - let: ts' := pword_of_word (ts - wrepr Uptr sz) in - let: s' := with_vm s (evm s).[vrsp <- ok ts']%vmap in - (evm s).[vrsp]%vmap = ok (pword_of_word ts) + let: ts' := Vword (ts - wrepr Uptr sz) in + let: s' := with_vm s (evm s).[vrsp <- ts'] in + (evm s).[vrsp] = Vword ts -> eval_instr lp i (of_estate s fn pc) = ok (of_estate s' fn pc.+1). Proof. move=> /= Hvm. rewrite /eval_instr /= /sem_sopn /=. - rewrite /get_gvar /get_var /on_vu /=. - rewrite Hvm /=. - by rewrite /sem_sop2 /exec_sopn /= !truncate_word_u /= truncate_word_u /= pword_of_wordE. + by rewrite /get_gvar /get_var /= Hvm /= /sem_sop2 /exec_sopn /= !truncate_word_u /= truncate_word_u. Qed. Definition x86_spec_lip_free_stack_frame s pc ii ts sz : let args := lip_free_stack_frame x86_liparams vrspi sz in let i := MkLI ii (Lopn args.1.1 args.1.2 args.2) in - let ts' := pword_of_word (ts + wrepr Uptr sz) in - let s' := with_vm s (evm s).[vrsp <- ok ts']%vmap in - (evm s).[vrsp]%vmap = ok (pword_of_word ts) + let ts' := Vword (ts + wrepr Uptr sz) in + let s' := with_vm s (evm s).[vrsp <- ts'] in + (evm s).[vrsp] = Vword ts -> eval_instr lp i (of_estate s fn pc) = ok (of_estate s' fn pc.+1). Proof. move=> /= Hvm. rewrite /eval_instr /= /sem_sopn /=. - rewrite /get_gvar /get_var /on_vu /=. + rewrite /get_gvar /get_var /=. rewrite Hvm /=. - by rewrite /sem_sop2 /exec_sopn /= !truncate_word_u /= truncate_word_u /= pword_of_wordE. + by rewrite /sem_sop2 /exec_sopn /= !truncate_word_u /= truncate_word_u. Qed. Lemma x86_spec_lip_set_up_sp_register s r ts al sz P Q : @@ -268,29 +264,26 @@ Lemma x86_spec_lip_set_up_sp_register s r ts al sz P Q : -> vtmp <> vrsp -> vname (v_var r) \notin (lip_not_saved_stack x86_liparams) -> v_var r <> vrsp - -> get_var (evm s) vrsp = ok (Vword ts) - -> wf_vm (evm s) + -> get_var true (evm s) vrsp = ok (Vword ts) -> exists vm', let: ls := of_estate s fn (size P) in let: s' := with_vm s vm' in let: ls' := of_estate s' fn (size P + size lcmd) in [/\ lsem lp ls ls' - , wf_vm vm' - , vm' = (evm s) - [\ Sv.add (v_var r) (Sv.add vtmp (Sv.add vrsp vflags)) ] - , get_var vm' vrsp = ok (Vword ts') - , get_var vm' (v_var r) = ok (Vword ts) + , vm' =[\ Sv.add (v_var r) (Sv.add vtmp (Sv.add vrsp vflags)) ] (evm s) + , get_var true vm' vrsp = ok (Vword ts') + , get_var true vm' (v_var r) = ok (Vword ts) & forall x, Sv.In x vflags - -> ~ is_ok (vm'.[x]%vmap) - -> (evm s).[x]%vmap = vm'.[x]%vmap + -> ~ is_defined vm'.[x] + -> (evm s).[x] = vm'.[x] ]. Proof. move=> hbody _ hr. set ts' := align_word _ _. move: r hr hbody => [[rtype rname] rinfo] /= ?; subst rtype. set r := {| v_info := rinfo; |}. - move=> hbody _ _ hneq_r_rsp hgetrsp hwf_vm. + move=> hbody _ _ hneq_r_rsp hgetrsp. move: hbody. set i_mov_r := _ _ (x86_lassign (LLvar r) _ _). @@ -298,8 +291,8 @@ Proof. set i_align_rsp := _ _ (x86_op_align vrspi _ _). move=> hbody. - set vm0 := (evm s).[v_var r <- ok (pword_of_word ts)]%vmap. - set vm2 := vm0.[vrsp <- ok (pword_of_word (ts - wrepr Uptr sz))]%vmap. + set vm0 := (evm s).[v_var r <- Vword ts]. + set vm2 := vm0.[vrsp <- Vword (ts - wrepr Uptr sz)]. eexists. split. @@ -313,19 +306,14 @@ Proof. * exact: hgetrsp. * exact: truncate_word_u. rewrite /write_lval /write_var /=. - rewrite /with_vm pword_of_wordE -/vm0. + rewrite /with_vm -/vm0. reflexivity. (* R[rsp] := R[rsp] - sz; *) + rewrite (find_instr_skip hbody) /=. apply: x86_spec_lip_allocate_stack_frame. - rewrite Fv.setP_neq; last by apply/eqP. - move: hgetrsp. - rewrite get_varE. - case: _.[_]%vmap => //= -[pws w ?]. - move=> [?]; subst pws. - move=> [?]; subst w. - rewrite pword_of_wordE. + rewrite Vm.setP_neq; last by apply/eqP. + move /get_varP: hgetrsp => [<- _ _]. reflexivity. (* R[rsp] := R[rsp] & alignment; *) @@ -338,9 +326,7 @@ Proof. (w := ts - wrepr Uptr sz) _ _ _ (cmp_le_refl _)). - by t_get_var. - - - repeat apply: wf_vm_set. exact: hwf_vm. + by rewrite /get_var /= /vm2 Vm.setP_eq vm_truncate_val_eq //. - move=> x. t_notin_add. by t_vm_get. @@ -350,9 +336,9 @@ Proof. rewrite /= -/ts'. move=> x /sv_of_listP /mapP [f _ ->]. - rewrite Fv.setP_neq //. + rewrite Vm.setP_neq //. case: f; - by repeat (rewrite Fv.setP_neq; last by apply /eqP => h; have := inj_to_var h); rewrite Fv.setP_eq. + by repeat (rewrite Vm.setP_neq; last by apply /eqP => h; have := inj_to_var h); rewrite Vm.setP_eq. Qed. Lemma x86_spec_lip_set_up_sp_stack s ts m' al sz off P Q : @@ -361,25 +347,23 @@ Lemma x86_spec_lip_set_up_sp_stack s ts m' al sz off P Q : is_linear_of lp fn (P ++ lcmd ++ Q) -> isSome (lip_set_up_sp_stack x86_liparams vrspi sz al off) -> vtmp <> vrsp - -> get_var (evm s) vrsp = ok (Vword ts) - -> wf_vm (evm s) + -> get_var true (evm s) vrsp = ok (Vword ts) -> write (emem s) (ts' + wrepr Uptr off)%R ts = ok m' -> exists vm', let: ls := of_estate s fn (size P) in let: s' := {| escs := escs s; evm := vm'; emem := m'; |} in let: ls' := of_estate s' fn (size P + size lcmd) in [/\ lsem (spp := mk_spp) lp ls ls' - , wf_vm vm' - , vm' = (evm s) [\ Sv.add vtmp (Sv.add vrsp vflags) ] - , get_var vm' vrsp = ok (Vword ts') + , vm' =[\ Sv.add vtmp (Sv.add vrsp vflags) ] (evm s) + , get_var true vm' vrsp = ok (Vword ts') & forall x, Sv.In x vflags - -> ~ is_ok (vm'.[x]%vmap) - -> (evm s).[x]%vmap = vm'.[x]%vmap + -> ~ is_defined vm'.[x] + -> (evm s).[x] = vm'.[x] ]. Proof. set ts' := align_word _ _. - move=> hbody _ hneq_tmp_rsp hgetrsp hwf_vm hwrite. + move=> hbody _ hneq_tmp_rsp hgetrsp hwrite. move: hbody. rewrite /=. @@ -387,7 +371,7 @@ Proof. rewrite -[[:: _; _; _]]/(map _ (x86_set_up_sp_register vrspi sz al vtmpi)). move=> hbody. - have [vm0 [hsem hwf_vm0 hvm0 hgetrsp0 hgettmp0 hflags]] := + have [vm0 [hsem hvm0 hgetrsp0 hgettmp0 hflags]] := x86_spec_lip_set_up_sp_register (r := vtmpi) hbody @@ -396,8 +380,7 @@ Proof. hneq_tmp_rsp erefl hneq_tmp_rsp - hgetrsp - hwf_vm. + hgetrsp. exists vm0. split. @@ -422,8 +405,6 @@ Proof. rewrite -/ts'. by rewrite /= hwrite {hwrite}. - - exact: hwf_vm0. - - move=> x hx. rewrite hvm0; first done. rewrite Sv_equal_add_add. @@ -469,12 +450,11 @@ Qed. (* Lowering hypotheses. *) (* Due to the order of the parameters we can't defined this as a record. *) -Definition x86_hloparams : h_lowering_params (ap_lop x86_params). +Definition x86_hloparams {dc : DirectCall} : h_lowering_params (ap_lop x86_params). Proof. split. exact: @lower_callP. Defined. - (* ------------------------------------------------------------------------ *) (* Assembly generation hypotheses. *) @@ -582,21 +562,14 @@ Qed. Lemma lom_eqv_set_xreg rip (xr : xreg_t) m s : lom_eqv rip m s -> - let: pw := - {| - pw_size := U256; - pw_word := asm_xreg s xr; - pw_proof := erefl (U256 ≤ U256)%CMP; - |} - in - lom_eqv rip (with_vm m (evm m).[to_var xr <- ok pw]%vmap) s. + lom_eqv rip (with_vm m (evm m).[to_var xr <- Vword (asm_xreg s xr)]) s. Proof. case => h1 h2 h3 h4 h5 h6 h7 h9; split => //; rewrite /eqflags /get_var /=. - + by rewrite Fv.setP_neq //; apply/eqP; case: h4; auto. - 1,2,4: by move=> x v; rewrite Fv.setP_neq; auto. - move=> x v; case: (to_var xr =P to_var x) => [h | /eqP hne]. - + move: (inj_to_var h) => ->. by rewrite Fv.setP_eq => -[<-]. - by rewrite Fv.setP_neq; auto. + + by rewrite Vm.setP_neq //; apply/eqP; case: h4; auto. + 1,2,4: by move=> x; rewrite Vm.setP_neq; auto. + move=> x; case: (to_var xr =P to_var x) => [h | /eqP hne]. + + move: (inj_to_var h) => ->. by rewrite Vm.setP_eq. + by rewrite Vm.setP_neq; auto. Qed. Lemma check_sopn_args_xmm rip ii oargs es ads cond n k ws: @@ -697,13 +670,16 @@ Proof. move: hwm; rewrite /mem_write_vals /= /mem_write_val /= !truncate_word_u /= truncate_word_u /= => <-; do 2!f_equal. rewrite /winserti128 /split_vec /=; f_equal. congr (fun x => [::x; wh]). - case: hlow => _ _ _ _ _ _ /(_ _ _ hvl) hu _. - move: hwl hu; rewrite /to_word. - case: (vl) => // [ws wl' /= | []//]. - rewrite /word_uincl mul0n => /truncate_wordP[] hle ? /andP[] _ /eqP ?; subst. + case: hlow => _ _ _ _ _ _ hu _. + move /get_varP: hvl => -[]/= ? hd _; subst vl. + have := hu lr. + case: (evm m).[to_var lr] hd hwl => //= ws wl' _ /truncate_wordP [] hle ? /andP[] _ /eqP ?; subst. + rewrite /word_uincl mul0n. by rewrite (@subword0 U128 U256) zero_extend_idem. Qed. + + Lemma assemble_extra_op rip ii op lvs args m xs ys m' s ops ops': sem_rexprs m args = ok xs -> exec_sopn (Oasm (ExtOp op)) xs = ok ys -> @@ -796,7 +772,6 @@ Proof. move: (hlow) => [h0 h1 hrip hd h2 h2x h3 h4]. move: hwx; rewrite /write_var /set_var. rewrite -xr => -[<-]{m1}. - rewrite -/(to_pword _ (Vword (zero_extend U64 _))). apply: (lom_eqv_write_reg _ _ hlow). by right. @@ -829,7 +804,7 @@ Proof. rewrite (free_vars_rP (vm2:= vm) (vm1:=evm m) (r:=emsf) (emem m)); last by apply: set_var_disjoint_eq_on haux2 hset. move=> _ -> _ _ -> <- -> [->] /=. - by rewrite (get_var_set_var vaux hset) eqxx /sem_sop1 /= hb haux. + by move/set_varP : hset => -[?? ->];rewrite /get_var /= Vm.setP_eq /sem_sop1 /= hb haux. have hws : write_lexprs [:: x] [:: Vword (if ~~ b then wrepr U64 (-1) else w)] (with_vm m vm) = ok m2. + by rewrite /= hw2. have []:= compile_asm_opn_aux eval_assemble_cond hes _ hws hca hcd hidc hlo. @@ -872,55 +847,51 @@ Opaque cat. have [yr [vi /= hy _ ]] := check_sopn_dests_xmm (n:= 0) hcd hidc erefl erefl erefl. pose v0 := (s.(asm_xreg) xr). - pose (pv0 := @Build_pword U256 U256 v0 erefl). - pose (vm0 := ((evm m).[to_var xr <- ok pv0])%vmap). + pose (vm0 := (evm m).[to_var xr <- Vword v0]). pose (m0 := with_vm m vm0). have hlo0: lom_eqv rip m0 s by apply lom_eqv_set_xreg. move: hes1 => /=; t_xrbindP => z hew _ z1 hemsf <- ? [?]; subst z z1. have heqvm0 : vm0 =[free_vars_r emsf] evm m. - + by apply/eq_onS/(set_var_disjoint_eq_on (x:= to_var xr) (v:= Vword (s.(asm_xreg) xr))). + + by apply/eq_onS/(set_var_disjoint_eq_on (wdb:=true) (x:= to_var xr) (v:= Vword (s.(asm_xreg) xr))). move: hmap; rewrite -hops !mapM_cat; t_xrbindP. move=> ops1' hmap1 _ ops2' hmap2 ops3' hmap3 <- <-. rewrite foldM_cat. (* first instruction *) pose v1 := wpinsr (zero_extend U128 (s.(asm_xreg) xr)) wmsf (wrepr U8 0). - pose (pv1 := (@Build_pword U256 U128 v1 erefl)). - pose (vm1 := ((evm m0).[to_var xr <- ok pv1])%vmap). + pose (vm1 := ((evm m0).[to_var xr <- Vword v1])). pose (m1 := with_vm m vm1). (* second instruction *) pose v2 := wpbroadcast U128 wmsf. - pose (pv2 := (@Build_pword U256 U128 v2 erefl)). - pose (vm2 := ((evm m1).[to_var xr <- ok pv2])%vmap). + pose (vm2 := ((evm m1).[to_var xr <- Vword v2])). pose (m2 := with_vm m vm2). have /(_ m2) [|s2 -> hlo2] /= := assemble_opsP eval_assemble_cond hmap1 erefl _ hlo0. - + have -> /=: get_var vm0 (to_var xr) = ok (Vword (s.(asm_xreg) xr)). - + by rewrite /get_var /vm0 Fv.setP_eq /=. + + have -> /=: get_var true vm0 (to_var xr) = ok (Vword (s.(asm_xreg) xr)). + + by rewrite /get_var /vm0 Vm.setP_eq /=. have -> /= : sem_rexpr (emem m) vm0 emsf = ok vmsf. + by rewrite -hemsf; apply: free_vars_rP. rewrite /exec_sopn /= hmsf /= !truncate_word_le // /=. have -> : wand (wrepr U8 0) (x86_nelem_mask U64 U128) = wrepr U8 0. + by apply/wunsigned_inj/(wand_modulo _ 1). - have -> /=: get_var vm1 (to_var xr) = ok (Vword v1). - + by rewrite /get_var /vm0 Fv.setP_eq /=. + have -> /=: get_var true vm1 (to_var xr) = ok (Vword v1). + + by rewrite /get_var /vm0 Vm.setP_eq /=. have -> /= : sem_rexpr (emem m) vm1 emsf = ok vmsf. + rewrite -hemsf; apply: free_vars_rP. apply/(eq_onT (vm2:= vm0)) => //. - by apply/eq_onS/(set_var_disjoint_eq_on (x:= to_var xr) (v:= Vword v1)). + by apply/eq_onS/(set_var_disjoint_eq_on (wdb := true) (x:= to_var xr) (v:= Vword v1)). rewrite /exec_sopn /= hmsf /= !truncate_word_u /=. have -> : wand (wrepr U8 1) (x86_nelem_mask U64 U128) = wrepr U8 1. + by apply/wunsigned_inj/(wand_modulo _ 1). - rewrite /m2 /= /vm2 /pv2 /v2 /with_vm /=. + rewrite /m2 /= /vm2 /v2 /with_vm /=. do 5! f_equal. rewrite /wpinsr /v2 /wpbroadcast /= /v1 /wpinsr /=. by rewrite subword_make_vec_bits_low. rewrite foldM_cat => {hmap1 hops}. (* third write *) pose v3 := wpbroadcast ws wmsf. - pose (pv3 := (@Build_pword U256 ws v3 (wsize_ge_U256 ws))). - pose (vm3 := ((evm m2).[to_var xr <- ok pv3])%vmap). + pose (vm3 := ((evm m2).[to_var xr <- Vword v3])). pose (m3 := with_vm m2 vm3). have : exists2 s3, foldM (fun '(op'', asm_args) => [eta eval_op op'' asm_args]) s2 ops2' = ok s3 & @@ -930,46 +901,43 @@ Opaque cat. eexists; first reflexivity. apply: (lom_eqv_ext _ hlo2). move=> z; rewrite /vm3. - case: (to_var xr =P z) => [<- | /eqP ?]; last by rewrite Fv.setP_neq. - rewrite /m2 /vm2 /= !Fv.setP_eq /pv2 /pv3. + case: (to_var xr =P z) => [<- | /eqP ?]; last by rewrite Vm.setP_neq. + rewrite /m2 /vm2 /= !Vm.setP_eq. have ? : ws = U128 by case: (ws) hws1 Hws. - by subst ws; rewrite -(Eqdep_dec.UIP_refl_bool _ (wsize_ge_U256 U128)). + by subst ws. subst ws => hmap2. apply: (@assemble_extra_concat128 rip ii [:: LLvar aux] [:: Rexpr (Fvar aux); Rexpr (Fvar aux)] m2 [:: Vword v2; Vword v2] [:: Vword (wpbroadcast U256 wmsf)] m3 s2 _ ops2') hmap2 hlo2 => //=. - + by rewrite /get_var /vm2 Fv.setP_eq. - + rewrite /exec_sopn /= truncate_word_u /=; do 3!f_equal. - rewrite /v2 /wpbroadcast /=. - exact: make_vec_4x64. - by rewrite -(Eqdep_dec.UIP_refl_bool _ (wsize_ge_U256 U256)). + + by rewrite /get_var /vm2 Vm.setP_eq. + rewrite /exec_sopn /= truncate_word_u /=; do 3!f_equal. + rewrite /v2 /wpbroadcast /=. + exact: make_vec_4x64. Transparent cat. move=> [s3 -> hlo3] /= {hmap2}. (* fourth instruction *) move: hws; subst y => /=. - rewrite (sumbool_of_boolET (wsize_ge_U256 ws)) /with_vm /=. - set v4 := wor _ _; set pv4 := {| pw_word := v4 |}. - set vm1' := ((evm m).[ _ <- _])%vmap => -[<-]. - pose (vm4 := (vm3 .[ to_var yr <- ok pv4])%vmap). + rewrite /with_vm /=. + set v4 := wor _ _. + set vm1' := ((evm m).[ _ <- _]) => -[<-]. + pose (vm4 := (vm3 .[ to_var yr <- Vword v4])). have /(_ (with_vm m vm4)) [|s' -> hlo4] /= := assemble_opsP eval_assemble_cond hmap3 erefl _ hlo3. - + have -> /=: get_var vm3 (to_var xr) = ok (Vword v3). - + by rewrite /get_var /vm3 Fv.setP_eq /=. + + have -> /=: get_var true vm3 (to_var xr) = ok (Vword v3). + + by rewrite /get_var /vm3 Vm.setP_eq /= wsize_ge_U256. have -> /= : sem_rexpr (emem m) vm3 ew = ok vw. + rewrite -hew; apply: free_vars_rP. apply/eq_onS/(eq_onT (vm2:= vm2)); [ apply/(eq_onT (vm2:= vm1)); [ apply/(eq_onT (vm2:= vm0)) | ] | ]. - + by apply(set_var_disjoint_eq_on (x:= to_var xr) (v:= Vword v0)). - + by apply/(set_var_disjoint_eq_on (x:= to_var xr) (v:= Vword v1)). - + by apply/(set_var_disjoint_eq_on (x:= to_var xr) (v:= Vword v2)). - apply/(set_var_disjoint_eq_on (x:= to_var xr) (v:= Vword v3)) => //. - by rewrite /set_var /= (sumbool_of_boolET (wsize_ge_U256 ws)). + + by apply(set_var_disjoint_eq_on (wdb := true) (x:= to_var xr) (v:= Vword v0)). + + by apply(set_var_disjoint_eq_on (wdb := true) (x:= to_var xr) (v:= Vword v1)). + + by apply(set_var_disjoint_eq_on (wdb := true) (x:= to_var xr) (v:= Vword v2)). + apply/(set_var_disjoint_eq_on (wdb := true) (x:= to_var xr) (v:= Vword v3)) => //. by rewrite /exec_sopn /= truncate_word_u hw /= /sopn_sem /= /x86_VPOR /x86_u128_binop - /check_size_128_256 Hws' /= (wsize_ge_U256 ws) /= - (sumbool_of_boolET (wsize_ge_U256 ws)). + /check_size_128_256 Hws' /= (wsize_ge_U256 ws) /=. exists s' => //; apply: lom_eqv_ext hlo4 => z /=. - rewrite /vm4; case: (to_var yr =P z) => [ | /eqP] ?;first by subst z; rewrite !Fv.setP_eq. - rewrite Fv.setP_neq // Fv.setP_neq // /vm3 /m2 /vm2 /m1 /vm1 /m0 /vm0 /vm1' /=. - case: (to_var xr =P z) => [<- | /eqP ?]; first by rewrite !Fv.setP_eq. - by rewrite !Fv.setP_neq. + rewrite /vm4; case: (to_var yr =P z) => [ | /eqP] ?;first by subst z; rewrite !Vm.setP_eq. + rewrite Vm.setP_neq // Vm.setP_neq // /vm3 /m2 /vm2 /m1 /vm1 /m0 /vm0 /vm1' /=. + case: (to_var xr =P z) => [<- | /eqP ?]; first by rewrite !Vm.setP_eq. + by rewrite !Vm.setP_neq. Qed. Definition x86_hagparams : h_asm_gen_params (ap_agp x86_params) := @@ -1034,7 +1002,7 @@ Qed. (* ------------------------------------------------------------------------ *) -Definition x86_h_params {call_conv : calling_convention} : h_architecture_params x86_params := +Definition x86_h_params {dc : DirectCall} {call_conv : calling_convention} : h_architecture_params x86_params := {| hap_hpip := x86_hpiparams; hap_hsap := x86_hsaparams; diff --git a/proofs/lang/expr.v b/proofs/lang/expr.v index 4d136d12b..b0dae0c27 100644 --- a/proofs/lang/expr.v +++ b/proofs/lang/expr.v @@ -769,6 +769,19 @@ Definition write_c_rec s c := foldl write_I_rec s c. Definition write_c c := write_c_rec Sv.empty c. +(* ** Expression depends/reads on memory + * -------------------------------------------------------------------- *) + +Fixpoint use_mem (e : pexpr) := + match e with + | Pconst _ | Pbool _ | Parr_init _ | Pvar _ => false + | Pload _ _ _ => true + | Pget _ _ _ e | Psub _ _ _ _ e | Papp1 _ e => use_mem e + | Papp2 _ e1 e2 => use_mem e1 || use_mem e2 + | PappN _ es => has use_mem es + | Pif _ e e1 e2 => use_mem e || use_mem e1 || use_mem e2 + end. + (* ** Compute read variables * -------------------------------------------------------------------- *) @@ -908,12 +921,3 @@ Definition instr_of_copn_args : instr_r := Copn args.1.1 tg args.1.2 args.2. -Fixpoint use_mem (e : pexpr) : bool := - match e with - | Pconst _ | Pbool _ | Parr_init _ | Pvar _ => false - | Pload _ _ _ => true - | Pget _ _ _ e | Psub _ _ _ _ e | Papp1 _ e => use_mem e - | Papp2 _ e1 e2 => use_mem e1 || use_mem e2 - | PappN _ es => has use_mem es - | Pif _ e e1 e2 => use_mem e || use_mem e1 || use_mem e2 - end. diff --git a/proofs/lang/expr_facts.v b/proofs/lang/expr_facts.v index 0144709b8..396829be6 100644 --- a/proofs/lang/expr_facts.v +++ b/proofs/lang/expr_facts.v @@ -759,3 +759,59 @@ Proof. - by move => <-; left. by move => ne; right => - []. Qed. + +(* -------------------------------------------------------------------- *) + +Section WRANGE. +Local Open Scope Z_scope. +Import Psatz. + +Lemma size_wrange d z1 z2 : + size (wrange d z1 z2) = Z.to_nat (z2 - z1). +Proof. by case: d => /=; rewrite ?size_rev size_map size_iota. Qed. + +Lemma nth_wrange z0 d z1 z2 n : (n < Z.to_nat (z2 - z1))%nat -> + nth z0 (wrange d z1 z2) n = + if d is UpTo + then z1 + Z.of_nat n + else z2 - Z.of_nat n. +Proof. +case: d => ltn /=; + by rewrite (nth_map 0%nat) ?size_iota ?nth_iota. +Qed. + +Lemma last_wrange_up_ne z0 lo hi : + lo < hi -> last z0 (wrange UpTo lo hi) = hi - 1. +Proof. +move=> lt; rewrite -nth_last nth_wrange; last rewrite size_wrange prednK //. +rewrite size_wrange -subn1 Nat2Z.inj_sub; first by rewrite Z2Nat.id; lia. ++ apply/leP/ltP; rewrite -Z2Nat.inj_0; apply Z2Nat.inj_lt; lia. ++ apply/ltP; rewrite -Z2Nat.inj_0; apply Z2Nat.inj_lt; lia. +Qed. + +Lemma last_wrange_up lo hi : last (hi-1) (wrange UpTo lo hi) = hi - 1. +Proof. +case: (Z_lt_le_dec lo hi) => [lt|le]; first by apply: last_wrange_up_ne. +rewrite -nth_last nth_default // size_wrange. +by rewrite [Z.to_nat _](_ : _ = 0%nat) ?Z_to_nat_le0 //; lia. +Qed. + +Lemma wrange_cons lo hi : lo <= hi -> + lo - 1 :: wrange UpTo lo hi = wrange UpTo (lo - 1) hi. +Proof. +set s1 := wrange _ _ _; set s2 := wrange _ _ _ => /=. +move=> lt; apply/(@eq_from_nth _ 0) => /=. ++ rewrite {}/s1 {}/s2 !size_wrange -Z2Nat.inj_succ; last lia. + by apply: Nat2Z.inj; rewrite !Z2Nat.id; lia. +rewrite {1}/s1 size_wrange; case => [|i]. ++ rewrite /s2 nth_wrange /=; try lia. + by rewrite -Z2Nat.inj_0; apply/leP/Z2Nat.inj_lt; lia. +move=> lti; rewrite -[nth _ (_ :: _) _]/(nth 0 s1 i) {}/s1 {}/s2. +rewrite !nth_wrange; first lia; last first. ++ by apply/leP; move/leP: lti; lia. +apply/leP/Nat2Z.inj_lt; rewrite Z2Nat.id; last lia. +move/leP/Nat2Z.inj_lt: lti; try rewrite -Z2Nat.inj_succ; last lia. +by rewrite Z2Nat.id; lia. +Qed. + +End WRANGE. diff --git a/proofs/lang/extraction.v b/proofs/lang/extraction.v index f3f2aac47..04f616dcd 100644 --- a/proofs/lang/extraction.v +++ b/proofs/lang/extraction.v @@ -60,9 +60,10 @@ Extraction Blacklist String List Nat Utils Var Array. Separate Extraction utils warray_ + sem_type sopn expr - sem + psem_defs sem_params_of_arch_extra arch_decl arch_extra diff --git a/proofs/lang/fexpr_facts.v b/proofs/lang/fexpr_facts.v index fe14505a9..50b68f13f 100644 --- a/proofs/lang/fexpr_facts.v +++ b/proofs/lang/fexpr_facts.v @@ -39,14 +39,16 @@ Qed. Section Section. Context + {wsw : WithSubWord} {syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} + (wdb : bool) (gd : glob_decls). Lemma fexpr_of_pexprP s e f v : fexpr_of_pexpr e = Some f → - sem_pexpr gd s e = ok v → + sem_pexpr true gd s e = ok v → sem_fexpr (evm s) f = ok v. Proof. elim: e f v => //=. @@ -74,7 +76,7 @@ Qed. Lemma rexpr_of_pexprP s e r v : rexpr_of_pexpr e = Some r → - sem_pexpr gd s e = ok v → + sem_pexpr true gd s e = ok v → sem_rexpr (emem s) (evm s) r = ok v. Proof. elim/rexpr_of_pexpr_ind: (rexpr_of_pexpr e). @@ -85,7 +87,7 @@ Qed. Lemma lexpr_of_lvalP x d s v s' : lexpr_of_lval x = Some d → - write_lval gd x v s = ok s' → + write_lval true gd x v s = ok s' → write_lexpr d v s = ok s'. Proof. case: x => //. @@ -119,7 +121,7 @@ Lemma free_vars_rP vm2 vm1 r m: sem_rexpr m vm1 r = sem_rexpr m vm2 r. Proof. case: r => [w v f | f] /= heq; last by apply free_varsP. - rewrite (free_vars_recP heq) (get_var_eq_on _ heq) // free_varsE; SvD.fsetdec. + rewrite (free_vars_recP heq) (get_var_eq_on _ _ heq) // free_varsE; SvD.fsetdec. Qed. End Section. diff --git a/proofs/lang/fexpr_sem.v b/proofs/lang/fexpr_sem.v index 87c425ace..b40eddb56 100644 --- a/proofs/lang/fexpr_sem.v +++ b/proofs/lang/fexpr_sem.v @@ -4,13 +4,14 @@ Require Import psem. Section SEM_EXPR. (* Semantic of expressions *) - Context {pd: PointerData}. - Context (m: mem) (vm: vmap). + + Context {wsw : WithSubWord} {pd: PointerData}. + Context (m: mem) (vm: Vm.t). Fixpoint sem_fexpr (e: fexpr) : exec value := match e with | Fconst z => ok (Vint z) - | Fvar x => get_var vm x + | Fvar x => get_var true vm x | Fapp1 op a => Let v := sem_fexpr a in sem_sop1 op v | Fapp2 op a b=> Let v := sem_fexpr a in Let w := sem_fexpr b in sem_sop2 op v w | Fif a b c => Let u := sem_fexpr a >>= to_bool in Let v := sem_fexpr b >>= to_bool in Let w := sem_fexpr c >>= to_bool in ok (Vbool (if u then v else w)) @@ -18,7 +19,7 @@ Section SEM_EXPR. Definition sem_rexpr (e: rexpr) : exec value := match e with - | Load ws x a => Let p := get_var vm x >>= to_pointer in Let off := sem_fexpr a >>= to_pointer in Let v := read m (p + off)%R ws in ok (@to_val (sword ws) v) + | Load ws x a => Let p := get_var true vm x >>= to_pointer in Let off := sem_fexpr a >>= to_pointer in Let v := read m (p + off)%R ws in ok (@to_val (sword ws) v) | Rexpr a => sem_fexpr a end. @@ -27,19 +28,19 @@ End SEM_EXPR. Section SEM. Context - {syscall_state : Type} + {wsw : WithSubWord} {syscall_state : Type} {ep : EstateParams syscall_state}. Definition write_lexpr e v (s: estate) : exec estate := match e with | Store ws x a => - Let p := get_var (evm s) x >>= to_pointer in + Let p := get_var true (evm s) x >>= to_pointer in Let off := sem_fexpr (evm s) a >>= to_pointer in Let w := to_word ws v in Let m := write (emem s) (p + off)%R w in ok (with_mem s m) | LLvar x => - Let vm := set_var (evm s) x v in + Let vm := set_var true (evm s) x v in ok (with_vm s vm) end. diff --git a/proofs/lang/linear_sem.v b/proofs/lang/linear_sem.v index 754625570..65e5e4a4f 100644 --- a/proofs/lang/linear_sem.v +++ b/proofs/lang/linear_sem.v @@ -16,6 +16,8 @@ Unset Printing Implicit Defensive. Local Open Scope seq_scope. +#[local] Existing Instance withsubword. + Section SEM. Context @@ -43,7 +45,7 @@ Notation labels := label_in_lprog. Record lstate := Lstate { lscs : syscall_state_t; lmem : mem; - lvm : vmap; + lvm : Vm.t; lfn : funname; lpc : nat; }. @@ -96,16 +98,16 @@ Definition eval_instr (i : linstr) (s1: lstate) : exec lstate := Let s2 := write_lexprs xs res s in ok (of_estate s2 s1.(lfn) s1.(lpc).+1) | Lsyscall o => - Let ves := mapM (get_var s1.(lvm)) (syscall_sig o).(scs_vin) in + Let ves := mapM (get_var true s1.(lvm)) (syscall_sig o).(scs_vin) in Let: (scs, m, vs) := exec_syscall (semCallParams:= sCP_stack) s1.(lscs) s1.(lmem) o ves in - Let s2 := write_lvals [::] {| escs := scs; emem := m; evm := vm_after_syscall s1.(lvm) |} + Let s2 := write_lvals true [::] {| escs := scs; emem := m; evm := vm_after_syscall s1.(lvm) |} (to_lvals (syscall_sig o).(scs_vout)) vs in ok (of_estate s2 s1.(lfn) s1.(lpc).+1) | Lcall None d => let vrsp := v_var (vid (lp_rsp P)) in - Let sp := get_var s1.(lvm) vrsp >>= to_pointer in + Let sp := get_var true s1.(lvm) vrsp >>= to_pointer in let nsp := (sp - wrepr Uptr (wsize_size Uptr))%R in - Let vm := set_var s1.(lvm) vrsp (Vword nsp) in + Let vm := set_var true s1.(lvm) vrsp (Vword nsp) in Let lbl := get_label_after_pc s1 in if encode_label labels (lfn s1, lbl) is Some p then Let m := write s1.(lmem) nsp p in @@ -120,7 +122,7 @@ Definition eval_instr (i : linstr) (s1: lstate) : exec lstate := | Lcall (Some r) d => Let lbl := get_label_after_pc s1 in if encode_label labels (lfn s1, lbl) is Some p then - Let vm := set_var s1.(lvm) r (Vword p) in + Let vm := set_var true s1.(lvm) r (Vword p) in let s1' := {| lscs := s1.(lscs); lmem := s1.(lmem); @@ -131,10 +133,10 @@ Definition eval_instr (i : linstr) (s1: lstate) : exec lstate := else type_error | Lret => let vrsp := v_var (vid (lp_rsp P)) in - Let sp := get_var s1.(lvm) vrsp >>= to_pointer in + Let sp := get_var true s1.(lvm) vrsp >>= to_pointer in let nsp := (sp + wrepr Uptr (wsize_size Uptr))%R in Let p := read s1.(lmem) sp Uptr in - Let vm := set_var s1.(lvm) vrsp (Vword nsp) in + Let vm := set_var true s1.(lvm) vrsp (Vword nsp) in let s1' := {| lscs := s1.(lscs); lmem := s1.(lmem); @@ -155,7 +157,7 @@ Definition eval_instr (i : linstr) (s1: lstate) : exec lstate := | LstoreLabel x lbl => if encode_label labels (lfn s1, lbl) is Some p then - Let vm := set_var s1.(lvm) x (Vword p) in + Let vm := set_var true s1.(lvm) x (Vword p) in ok {| lscs := s1.(lscs) ; lmem := s1.(lmem) ; lvm := vm ; lfn := s1.(lfn) ; lpc := s1.(lpc).+1 |} else type_error | Lcond e lbl => @@ -278,24 +280,6 @@ Proof. by move => b{}z ab /clos_rt_rt1n_iff bz; right; exists b. Qed. -(* -Variant lsem_fd (wrip: pointer) m1 fn va' m2 vr' : Prop := -| LSem_fd : forall m1' fd va vm2 m2' s1 s2 vr, - get_fundef P.(lp_funcs) fn = Some fd -> - alloc_stack m1 fd.(lfd_align) fd.(lfd_stk_size) = ok m1' -> - let c := fd.(lfd_body) in - write_vars [:: vid P.(lp_stk_id) ; vid P.(lp_rip)] - [:: Vword (top_stack m1'); Vword wrip] (Estate m1' vmap0) = ok s1 -> - mapM2 ErrType truncate_val fd.(lfd_tyin) va' = ok va -> - write_vars fd.(lfd_arg) va s1 = ok s2 -> - lsem (of_estate s2 fn c 0) - {| lmem := m2'; lvm := vm2; lfn := fn ; lc := c; lpc := size c |} -> - mapM (fun (x:var_i) => get_var vm2 x) fd.(lfd_res) = ok vr -> - mapM2 ErrType truncate_val fd.(lfd_tyout) vr = ok vr' -> - m2 = free_stack m2' fd.(lfd_stk_size) -> - lsem_fd wrip m1 fn va' m2 vr'. -*) - (* Linear execution state is final when it reaches the point after the last instruction. *) Definition lsem_final (s: lstate) : Prop := exists2 fd, get_fundef (lp_funcs P) (lfn s) = Some fd & lpc s = size fd.(lfd_body). @@ -317,7 +301,7 @@ Proof. by clear => s s' ? k _ _ /lsem_final_nostep /(_ k). Qed. -Variant lsem_exportcall (scs:syscall_state_t) (m: mem) (fn: funname) (vm: vmap) (scs':syscall_state_t) (m': mem) (vm': vmap) : Prop := +Variant lsem_exportcall (scs:syscall_state_t) (m: mem) (fn: funname) (vm: Vm.t) (scs':syscall_state_t) (m': mem) (vm': Vm.t) : Prop := | Lsem_exportcall (fd: lfundef) of get_fundef P.(lp_funcs) fn = Some fd & lfd_export fd diff --git a/proofs/lang/lowering_lemmas.v b/proofs/lang/lowering_lemmas.v index bf9926234..7276d1fe0 100644 --- a/proofs/lang/lowering_lemmas.v +++ b/proofs/lang/lowering_lemmas.v @@ -16,13 +16,14 @@ Unset Printing Implicit Defensive. Section ESTATE_EQ_EXCEPT. Context + {wsw : WithSubWord} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams}. (* State equality up to a set of variables. *) Definition estate_eq_except ys s1 s2 := - [/\ s1.(escs) = s2.(escs), s1.(emem) = s2.(emem) & s1.(evm) = s2.(evm) [\ ys]]. + [/\ s1.(escs) = s2.(escs), s1.(emem) = s2.(emem) & s1.(evm) =[\ ys] s2.(evm)]. (* FIXME syscall : why it is needed to redeclare it here *) (* note that in utils, it is CMorphisms.Proper, here it is Morpisms.Proper *) @@ -58,32 +59,32 @@ Proof. SvD.fsetdec. Qed. -Lemma eeq_exc_sem_pexprs gd xs es v s0 s1 : +Lemma eeq_exc_sem_pexprs wdb gd xs es v s0 s1 : disjoint (read_es es) xs -> estate_eq_except xs s1 s0 - -> sem_pexprs gd s0 es = ok v - -> sem_pexprs gd s1 es = ok v. + -> sem_pexprs wdb gd s0 es = ok v + -> sem_pexprs wdb gd s1 es = ok v. Proof. move=> hdisj heq. have [hscs hmem hvm] := eeq_exc_disjoint hdisj heq. - rewrite (read_es_eq_on gd hvm). + rewrite (read_es_eq_on wdb gd hvm). rewrite /with_vm. rewrite hscs hmem. by rewrite -(surj_estate s0). Qed. -Lemma eeq_exc_sem_pexpr gd xs e v s0 s1 : +Lemma eeq_exc_sem_pexpr wdb gd xs e v s0 s1 : disjoint (read_e e) xs -> estate_eq_except xs s1 s0 - -> sem_pexpr gd s0 e = ok v - -> sem_pexpr gd s1 e = ok v. + -> sem_pexpr wdb gd s0 e = ok v + -> sem_pexpr wdb gd s1 e = ok v. Proof. move=> hdisj heq hsem. have hdisj' : disjoint (read_es [:: e ]) xs. - done. - have hsem' : sem_pexprs gd s0 [:: e ] = ok [:: v ]. + have hsem' : sem_pexprs wdb gd s0 [:: e ] = ok [:: v ]. - by rewrite /= hsem. have := eeq_exc_sem_pexprs hdisj' heq hsem'. @@ -91,12 +92,12 @@ Proof. by t_xrbindP => ? ? <-. Qed. -Lemma eeq_exc_write_lvals gd xs s0 s1 s0' ls vs : +Lemma eeq_exc_write_lvals wdb gd xs s0 s1 s0' ls vs : disjoint (vars_lvals ls) xs -> estate_eq_except xs s0' s0 - -> write_lvals gd s0 ls vs = ok s1 + -> write_lvals wdb gd s0 ls vs = ok s1 -> exists2 s1', - write_lvals gd s0' ls vs = ok s1' & estate_eq_except xs s1' s1. + write_lvals wdb gd s0' ls vs = ok s1' & estate_eq_except xs s1' s1. Proof. move=> hdisj. move: s0 s0' => [scs0 mem0 vm0] [scs0' mem0' vm0']. @@ -110,9 +111,9 @@ Proof. clear hdisj. have hvm' : vm0 =[Sv.diff (read_rvs ls) xs] vm0'. - - move=> x hx. apply: vmap_eq_exceptS. apply: hvm. SvD.fsetdec. + - move=> x hx. apply: eq_exS. apply: hvm. SvD.fsetdec. - have [vm1' [hvm1' hwrite']] := write_lvals_eq_on hsub hwrite hvm'. + have [vm1' hwrite' hvm1'] := write_lvals_eq_on hsub hwrite hvm'. clear hsub hvm'. eexists; first exact: hwrite'. @@ -127,19 +128,19 @@ Proof. exact: hvm. Qed. -Lemma eeq_exc_write_lval gd xs s0 s1 s0' l v : +Lemma eeq_exc_write_lval wdb gd xs s0 s1 s0' l v : disjoint (vars_lval l) xs -> estate_eq_except xs s0' s0 - -> write_lval gd l v s0 = ok s1 + -> write_lval wdb gd l v s0 = ok s1 -> exists2 s1', - write_lval gd l v s0' = ok s1' & estate_eq_except xs s1' s1. + write_lval wdb gd l v s0' = ok s1' & estate_eq_except xs s1' s1. Proof. move=> hdisj heq hwrite. have hdisj' : disjoint (vars_lvals [:: l ]) xs. - done. - have hwrite' : write_lvals gd s0 [:: l ] [:: v ] = ok s1. + have hwrite' : write_lvals wdb gd s0 [:: l ] [:: v ] = ok s1. - by rewrite /= hwrite. have [s1' hwrite1 heq1] := eeq_exc_write_lvals hdisj' heq hwrite'. @@ -150,6 +151,18 @@ Proof. by t_xrbindP => ? ? <-. Qed. +Lemma eeq_exc_get_gvar wdb gd s0 s1 (x : gvar) vs : + ~~ Sv.mem (gv x) vs + -> estate_eq_except vs s0 s1 + -> get_gvar wdb gd (evm s0) x = get_gvar wdb gd (evm s1) x. +Proof. + move=> /Sv_memP hx [hscs hmem hvm]. + rewrite /get_gvar /=. + case: is_lvar; last done. + rewrite /get_var /=. + by rewrite (hvm _ hx). +Qed. + End ESTATE_EQ_EXCEPT. diff --git a/proofs/lang/psem.v b/proofs/lang/psem.v index 75ba40d9c..6498c6cf1 100644 --- a/proofs/lang/psem.v +++ b/proofs/lang/psem.v @@ -3,7 +3,10 @@ (* ** Imports and settings *) From mathcomp Require Import all_ssreflect all_algebra. Require Import Psatz xseq. -Require Export expr expr_facts low_memory syscall_sem sem. +Require Export array type expr gen_map low_memory warray_ sem_type sem_op_typed values varmap expr_facts low_memory syscall_sem psem_defs. +Require Export + flag_combination + sem_params. Import Utf8. Set Implicit Arguments. @@ -11,328 +14,47 @@ Unset Strict Implicit. Unset Printing Implicit Defensive. Local Open Scope Z_scope. -Local Open Scope vmap. Local Open Scope seq_scope. +Open Scope vm_scope. -(* ** Interpretation of types - * -------------------------------------------------------------------- *) - -Record pword s := - { pw_size: wsize; - pw_word : word pw_size; - pw_proof : (pw_size <= s)%CMP }. - -Definition psem_t (t : stype) : Type := - match t with - | sbool => bool - | sint => Z - | sarr n => WArray.array n - | sword s => pword s - end. - -(* ** Default values - * -------------------------------------------------------------------- *) - -Definition pword_of_word (s:wsize) (w:word s) : pword s := - {|pw_word := w; pw_proof := cmp_le_refl s|}. - -Definition to_pword (s: wsize) (v: value) : exec (pword s) := - match v with - | Vword s' w => - ok ( - if Sumbool.sumbool_of_bool (s' ≤ s)%CMP is left heq - then {| pw_word := w ; pw_proof := heq |} - else pword_of_word (zero_extend s w)) - | Vundef (sword _) _ => undef_error - | _ => type_error - end. - -Definition pof_val t : value -> exec (psem_t t) := - match t return value -> exec (psem_t t) with - | sbool => to_bool - | sint => to_int - | sarr n => to_arr n - | sword s => to_pword s - end. - -Definition pto_val t : psem_t t -> value := - match t return psem_t t -> value with - | sbool => Vbool - | sint => Vint - | sarr n => fun a => Varr a - | sword s => fun w => Vword (pw_word w) - end. - -Lemma to_pwordI s v w : - to_pword s v = ok w → - ∃ s' w', - v = @Vword s' w' ∧ - w = if Sumbool.sumbool_of_bool (s' ≤ s)%CMP is left heq - then {| pw_word := w' ; pw_proof := heq |} - else pword_of_word (zero_extend s w'). -Proof. by case: v => // [ | [] // ] s' w' /= [<-]; exists s', w'. Qed. - -Lemma to_pword_u ws (w : word ws) : - to_pword ws (Vword w) = ok (pword_of_word w). -Proof. by rewrite /= sumbool_of_boolET. Qed. - -Lemma to_pword_undef w v : - to_pword w v = undef_error -> v = undef_w. -Proof. by case: v => //= -[] // w' e _; rewrite undef_x_vundef. Qed. - -Lemma type_of_val_to_pword sz v w : - type_of_val v = sword sz → to_pword sz v = ok w → - ∃ w' : word sz, w = pword_of_word w' ∧ v = Vword w'. -Proof. - move=> h; have := type_of_valI v; rewrite h => - [ -> | [w' ->] ] //=. - by rewrite sumbool_of_boolET => - [<-]; exists w'. -Qed. - -Lemma subtype_of_val_to_pword ws v (w : pword ws) : - subtype (sword ws) (type_of_val v) -> - to_pword ws v = ok w -> - exists ws' (w' : word ws'), - [/\ (ws <= ws')%CMP, w = pword_of_word (zero_extend ws w') & v = Vword w']. -Proof. - move=> /subtypeEl [] ws' [] hty /dup[] hle. - rewrite cmp_le_eq_lt => /orP []. - + rewrite -cmp_nle_lt => /negPf hlt. - move=> /to_pwordI [] ws'' [] w' [] ?; subst v. - case: hty => ?; subst ws''. - rewrite sumbool_of_boolEF => ->. - by exists ws', w'. - move=> /eqP ?; subst ws' => hto. - have [w' [hw hv]] := (type_of_val_to_pword hty hto). - exists ws, w'; split=> //. - by rewrite zero_extend_u. -Qed. - -(* ** Variable map +(* ** Parameter expressions * -------------------------------------------------------------------- *) -Notation vmap := (Fv.t (fun t => exec (psem_t t))). - -Definition pundef_addr t := - match t return exec (psem_t t) with - | sbool | sint | sword _ => undef_error - | sarr n => ok (@WArray.empty n) - end. - -Definition vmap0 : vmap := - @Fv.empty (fun t => exec (psem_t t)) (fun x => pundef_addr x.(vtype)). - -(* An access to a undefined value, leads to an error *) -Definition get_var (m:vmap) x := - on_vu (@pto_val (vtype x)) undef_error (m.[x]%vmap). - -#[ global ] Arguments get_var _%vmap_scope _. - -Lemma get_varE (m: vmap) x : - get_var m x = Let y := m.[x]%vmap in ok (pto_val y). -Proof. by rewrite /get_var; case: _.[_]%vmap => // - []. Qed. - -Definition get_gvar (gd: glob_decls) (vm: vmap) (x:gvar) := - if is_lvar x then get_var vm x.(gv) - else get_global gd x.(gv). - -Lemma get_gvar_glob gd x vm : is_glob x -> get_gvar gd vm x = get_global gd (gv x). -Proof. by rewrite /get_gvar /is_lvar /is_glob => /eqP ->. Qed. - -Lemma get_gvar_nglob gd x vm : ~~is_glob x -> get_gvar gd vm x = get_var vm (gv x). -Proof. by rewrite /get_gvar is_lvar_is_glob => ->. Qed. - -(* Assigning undefined value is allowed only for bool *) -Definition set_var (m:vmap) x v : exec vmap := - on_vu (fun v => m.[x<-ok v]%vmap) - (if is_sbool x.(vtype) then ok m.[x<-pundef_addr x.(vtype)]%vmap - else type_error) - (pof_val (vtype x) v). - -Lemma set_varP (m m':vmap) x v P : - (forall t, pof_val (vtype x) v = ok t -> m.[x <- ok t]%vmap = m' -> P) -> - ( is_sbool x.(vtype) -> pof_val (vtype x) v = undef_error -> - m.[x<-pundef_addr x.(vtype)]%vmap = m' -> P) -> - set_var m x v = ok m' -> P. -Proof. - move=> H1 H2;apply on_vuP => //. - by case:ifPn => // hb herr []; apply : H2. -Qed. - -Lemma set_well_typed_var (m: vmap) (x: var) (v: value) : - vtype x = type_of_val v → - set_var m x v = - if v is Vundef ty _ - then - if ty == sbool - then ok (m.[ x <- pundef_addr (vtype x) ]%vmap) - else type_error - else ok (m.[x <- pof_val (vtype x) v]%vmap). -Proof. - case: x => /= xt x ->. - rewrite /set_var /on_vu /=. - case: v => //=. - + by move=> ??; rewrite WArray.castK. - by case => //= ?; case:ifP. -Qed. - -Lemma get_var_set vm x v y : - get_var vm.[x <- ok v] y = if x == y then ok (pto_val v) else get_var vm y. -Proof. by rewrite {1}/get_var Fv.setP; case: eqP => // ?; subst. Qed. - -Lemma get_set_var vm x v vm' y : - set_var vm x v = ok vm' → - vm'.[y]%vmap = if x == y then pof_val (vtype y) v else vm.[y]%vmap. -Proof. - apply: set_varP. - 1: move => w ok_w. - 2: case: x => - [] //= x _ /to_bool_undef ->{v}. - all: by move => <-{vm'}; rewrite Fv.setP; case: eqP => // ?; subst. -Qed. - -Lemma get_var_set_var vm x v vm' y : - set_var vm x v = ok vm' → - get_var vm' y = if x == y then Let v' := pof_val (vtype y) v in ok (pto_val v') else get_var vm y. -Proof. - rewrite /get_var => /get_set_var ->. - case: eqP => // <-{y}. - by case: pof_val => // - []. -Qed. - -Lemma get_var_eq x vm v : get_var vm.[x <- v] x = on_vu (pto_val (t:=x.(vtype))) undef_error v. -Proof. by rewrite /get_var Fv.setP_eq. Qed. - -Lemma get_var_neq x y vm v : x <> y -> get_var vm.[x <- v] y = get_var vm y. -Proof. by move=> /eqP h; rewrite /get_var Fv.setP_neq. Qed. - -Lemma get_var_set_eq vm1 vm2 (x y : var) v: - get_var vm1 y = get_var vm2 y -> - get_var vm1.[x <- v] y = get_var vm2.[x <- v] y. -Proof. - by case:(x =P y) => [<- | hne]; rewrite !(get_var_eq, get_var_neq). -Qed. +Lemma sem_sop1I y x f: + sem_sop1 f x = ok y → + exists2 w : sem_t (type_of_op1 f).1, + of_val _ x = ok w & + y = to_val (sem_sop1_typed f w). +Proof. by rewrite /sem_sop1; t_xrbindP => w ok_w <-; eauto. Qed. -Lemma get_gvar_eq gd x vm v : - ~ is_glob x -> get_gvar gd vm.[x.(gv) <- v] x = on_vu (pto_val (t:=x.(gv).(vtype))) undef_error v. +Lemma sem_sop2I v v1 v2 f: + sem_sop2 f v1 v2 = ok v → + ∃ (w1 : sem_t (type_of_op2 f).1.1) (w2 : sem_t (type_of_op2 f).1.2) + (w3: sem_t (type_of_op2 f).2), + [/\ of_val _ v1 = ok w1, + of_val _ v2 = ok w2, + sem_sop2_typed f w1 w2 = ok w3 & + v = to_val w3]. Proof. - by move=> /negP => h; rewrite /get_gvar is_lvar_is_glob h get_var_eq. + by rewrite /sem_sop2; t_xrbindP => w1 ok_w1 w2 ok_w2 w3 ok_w3 <- {v}; exists w1, w2, w3. Qed. -Lemma get_gvar_neq gd (x:var) y vm v : - (~ is_glob y -> x <> (gv y)) -> get_gvar gd vm.[x <- v] y = get_gvar gd vm y. -Proof. - move=> h; rewrite /get_gvar is_lvar_is_glob. - by case: negP => // hg; rewrite get_var_neq //; apply h. -Qed. - -Definition vm_initialized_on (vm: vmap) : seq var → Prop := - all (λ x, is_ok (get_var vm x >>= of_val (vtype x))). - -(* Attempt to simplify goals of the form - [get_var vm.[y0 <- z0]...[yn <- zn] x]. *) -Ltac t_get_var := - repeat ( - rewrite get_var_eq - || (rewrite get_var_neq; last by [|apply/nesym]) - ). - -Definition eq_on (s : Sv.t) (vm1 vm2 : vmap) := - forall x, Sv.In x s -> vm1.[x]%vmap = vm2.[x]%vmap. - -Notation "vm1 '=[' s ']' vm2" := (eq_on s vm1 vm2) (at level 70, vm2 at next level, - format "'[hv ' vm1 =[ s ] '/' vm2 ']'"). - -Lemma eq_onT s vm1 vm2 vm3: - vm1 =[s] vm2 -> vm2 =[s] vm3 -> vm1 =[s] vm3. -Proof. by move=> H1 H2 x Hin;rewrite H1 ?H2. Qed. - -Lemma eq_onI s1 s2 vm1 vm2 : Sv.Subset s1 s2 -> vm1 =[s2] vm2 -> vm1 =[s1] vm2. -Proof. move=> Hs Heq x Hin. apply Heq. exact: (SvP.MP.in_subset Hin Hs). Qed. - -Lemma eq_onS vm1 s vm2 : vm1 =[s] vm2 -> vm2 =[s] vm1. -Proof. by move=> Heq x Hin;rewrite Heq. Qed. - -#[export] -Instance equiv_eq_on s: Equivalence (eq_on s). -Proof. - constructor=> //. - move=> ??;apply: eq_onS. - move=> ???;apply: eq_onT. -Qed. - -#[export] -Instance eq_on_impl : Proper (Basics.flip Sv.Subset ==> eq ==> eq ==> Basics.impl) eq_on. -Proof. by move=> s1 s2 H vm1 ? <- vm2 ? <-;apply: eq_onI. Qed. - -Global Instance eq_on_m : Proper (Sv.Equal ==> eq ==> eq ==> iff) eq_on. -Proof. by move=> s1 s2 Heq vm1 ? <- vm2 ? <-;split;apply: eq_onI;rewrite Heq. Qed. - -(* -------------------------------------------------------------------- *) - -Definition vmap_eq_except (s : Sv.t) (vm1 vm2 : vmap) := - forall x, ~Sv.In x s -> vm1.[x]%vmap = vm2.[x]%vmap. - -Notation "vm1 = vm2 [\ s ]" := (vmap_eq_except s vm1 vm2) (at level 70, vm2 at next level, - format "'[hv ' vm1 '/' = vm2 '/' [\ s ] ']'"). - -Lemma vmap_eq_exceptT vm2 s vm1 vm3: - vm1 = vm2 [\s] -> vm2 = vm3 [\s] -> vm1 = vm3 [\s]. -Proof. by move=> H1 H2 x Hin;rewrite H1 ?H2. Qed. - -Lemma vmap_eq_exceptI s1 s2 vm1 vm2 : Sv.Subset s1 s2 -> vm1 = vm2 [\s1] -> vm1 = vm2 [\s2]. -Proof. move=> Hs Heq x Hin;apply Heq;SvD.fsetdec. Qed. - -Lemma vmap_eq_except_union s1 s2 vm1 vm2 : - vm1 = vm2 [\ s1 ] - -> vm1 = vm2 [\ Sv.union s1 s2 ]. -Proof. apply: vmap_eq_exceptI. exact: SvP.MP.union_subset_1. Qed. - -Lemma vmap_eq_exceptTI s1 s2 vm1 vm2 vm3 : - vm1 = vm2 [\s1] -> - vm2 = vm3 [\s2] -> - vm1 = vm3 [\Sv.union s1 s2]. -Proof. - move => h12 h23; apply: vmap_eq_exceptT; apply: vmap_eq_exceptI. - 2: exact: h12. - 3: exact: h23. - all: SvD.fsetdec. -Qed. - -Lemma vmap_eq_exceptS vm1 s vm2 : vm1 = vm2 [\s] -> vm2 = vm1 [\s]. -Proof. by move=> Heq x Hin;rewrite Heq. Qed. +(* ** Global access + * -------------------------------------------------------------------- *) -Global Instance equiv_vmap_eq_except s: Equivalence (vmap_eq_except s). +Lemma get_globalI gd g v : + get_global gd g = ok v → + exists gv : glob_value, [/\ get_global_value gd g = Some gv, v = gv2val gv & type_of_val v = vtype g]. Proof. - constructor=> //. - move=> ??;apply: vmap_eq_exceptS. - move=> ???;apply: vmap_eq_exceptT. + rewrite /get_global; case: get_global_value => // gv. + by case:eqP => // <- [<-];exists gv. Qed. -Global Instance vmap_eq_except_impl : - Proper (Sv.Subset ==> eq ==> eq ==> Basics.impl) vmap_eq_except. -Proof. by move=> s1 s2 H vm1 ? <- vm2 ? <-;apply: vmap_eq_exceptI. Qed. - -Global Instance vmap_eq_except_m : Proper (Sv.Equal ==> eq ==> eq ==> iff) vmap_eq_except. -Proof. by move=> s1 s2 Heq vm1 ? <- vm2 ? <-;split;apply: vmap_eq_exceptI;rewrite Heq. Qed. - -Lemma vmap_eq_except_eq_on x y z e o : - x = y [\e] → - z =[o] y → - x =[Sv.diff o e] z. -Proof. move => he ho j hj; rewrite he ?ho; SvD.fsetdec. Qed. - -(* ** Parameter expressions - * -------------------------------------------------------------------- *) - -Record estate - {syscall_state : Type} - {ep : EstateParams syscall_state} := Estate - { - escs : syscall_state; - emem : mem; - evm : vmap - }. +Section WSW. +Context {wsw:WithSubWord}. -Arguments Estate {_ _} _ _ _. +(* ** State + * ------------------------------------------------------------------------- *) Section ESTATE_UTILS. @@ -340,15 +62,6 @@ Context {syscall_state : Type} {ep : EstateParams syscall_state}. -Definition with_vm (s:estate) vm := - {| escs := s.(escs); emem := s.(emem); evm := vm |}. - -Definition with_mem (s:estate) m := - {| escs := s.(escs); emem := m; evm := s.(evm) |}. - -Definition with_scs (s:estate) scs := - {| escs := scs; emem := s.(emem); evm := s.(evm) |}. - Lemma surj_estate s : s = {| escs := escs s; emem := emem s; evm := evm s |}. Proof. by case:s. Qed. @@ -381,152 +94,6 @@ Proof. by case: s. Qed. End ESTATE_UTILS. -Notation "'Let' ( n , t ) ':=' s '.[' v ']' 'in' body" := - (@on_arr_var _ (get_var s.(evm) v) (fun n (t:WArray.array n) => body)) (at level 25, s at level 0). - -Notation "'Let' ( n , t ) ':=' gd ',' s '.[' v ']' 'in' body" := - (@on_arr_var _ (get_gvar gd s.(evm) v) (fun n (t:WArray.array n) => body)) (at level 25, gd at level 0, s at level 0). - -Section SEM_PEXPR. - -Context - {asm_op syscall_state : Type} - {ep : EstateParams syscall_state} - {spp : SemPexprParams} - (gd : glob_decls). - -Fixpoint sem_pexpr (s:estate) (e : pexpr) : exec value := - match e with - | Pconst z => ok (Vint z) - | Pbool b => ok (Vbool b) - | Parr_init n => ok (Varr (WArray.empty n)) - | Pvar v => get_gvar gd s.(evm) v - | Pget aa ws x e => - Let (n, t) := gd, s.[x] in - Let i := sem_pexpr s e >>= to_int in - Let w := WArray.get aa ws t i in - ok (Vword w) - | Psub aa ws len x e => - Let (n, t) := gd, s.[x] in - Let i := sem_pexpr s e >>= to_int in - Let t' := WArray.get_sub aa ws len t i in - ok (Varr t') - | Pload sz x e => - Let w1 := get_var s.(evm) x >>= to_pointer in - Let w2 := sem_pexpr s e >>= to_pointer in - Let w := read s.(emem) (w1 + w2)%R sz in - ok (@to_val (sword sz) w) - | Papp1 o e1 => - Let v1 := sem_pexpr s e1 in - sem_sop1 o v1 - | Papp2 o e1 e2 => - Let v1 := sem_pexpr s e1 in - Let v2 := sem_pexpr s e2 in - sem_sop2 o v1 v2 - | PappN op es => - Let vs := mapM (sem_pexpr s) es in - sem_opN op vs - | Pif t e e1 e2 => - Let b := sem_pexpr s e >>= to_bool in - Let v1 := sem_pexpr s e1 >>= truncate_val t in - Let v2 := sem_pexpr s e2 >>= truncate_val t in - ok (if b then v1 else v2) - end. - -Definition sem_pexprs s := mapM (sem_pexpr s). - -Definition write_var (x:var_i) (v:value) (s:estate) : exec estate := - Let vm := set_var s.(evm) x v in - ok (with_vm s vm). - -Definition write_vars xs vs s := - fold2 ErrType write_var xs vs s. - -Definition write_none (s:estate) ty v := - on_vu (fun v => s) (if is_sbool ty then ok s else type_error) - (pof_val ty v). - -Definition write_lval (l:lval) (v:value) (s:estate) : exec estate := - match l with - | Lnone _ ty => write_none s ty v - | Lvar x => write_var x v s - | Lmem sz x e => - Let vx := get_var (evm s) x >>= to_pointer in - Let ve := sem_pexpr s e >>= to_pointer in - let p := (vx + ve)%R in (* should we add the size of value, i.e vx + sz * se *) - Let w := to_word sz v in - Let m := write s.(emem) p w in - ok (with_mem s m) - | Laset aa ws x i => - Let (n,t) := s.[x] in - Let i := sem_pexpr s i >>= to_int in - Let v := to_word ws v in - Let t := WArray.set t aa i v in - write_var x (@to_val (sarr n) t) s - | Lasub aa ws len x i => - Let (n,t) := s.[x] in - Let i := sem_pexpr s i >>= to_int in - Let t' := to_arr (Z.to_pos (arr_size ws len)) v in - Let t := @WArray.set_sub n aa ws len t i t' in - write_var x (@to_val (sarr n) t) s - end. - -Definition write_lvals (s:estate) xs vs := - fold2 ErrType write_lval xs vs s. - -End SEM_PEXPR. - -Section WITH_SCS. - - Context - {asm_op syscall_state : Type} - {ep : EstateParams syscall_state} - {spp : SemPexprParams} - (gd : glob_decls) - (s1 : estate) - (scs : syscall_state). - - Let P e : Prop := - sem_pexpr gd s1 e = sem_pexpr gd (with_scs s1 scs) e. - - Let Q es : Prop := - sem_pexprs gd s1 es = sem_pexprs gd (with_scs s1 scs) es. - - Lemma sem_pexpr_es_with_scs : (∀ e, P e) * (∀ es, Q es). - Proof. - apply: pexprs_ind_pair; split; subst P Q => //=; rewrite /sem_pexprs => *; - repeat match goal with H: _ = _ |- _ => rewrite H // end. - Qed. - - Definition sem_pexpr_with_scs := fst sem_pexpr_es_with_scs. - Definition sem_pexprs_with_scs := snd sem_pexpr_es_with_scs. - -End WITH_SCS. - -Section EXEC_ASM. - -Context - {asm_op syscall_state : Type} - {ep : EstateParams syscall_state} - {spp : SemPexprParams} - {asmop : asmOp asm_op}. - -Definition sem_sopn gd o m lvs args := - sem_pexprs gd m args >>= exec_sopn o >>= write_lvals gd m lvs. - -Lemma sopn_tinP o vs vs' : exec_sopn o vs = ok vs' -> - all2 subtype (sopn_tin o) (List.map type_of_val vs). -Proof. - rewrite /exec_sopn /sopn_tin /sopn_sem. - case (get_instr_desc o) => /= _ tin _ tout _ semi _ _. - t_xrbindP => p hp _. - elim: tin vs semi hp => /= [ | t tin hrec] [ | v vs] // semi. - by t_xrbindP => sv /= /of_val_subtype -> /hrec. -Qed. - -End EXEC_ASM. - - (* ** Instructions * -------------------------------------------------------------------- *) @@ -550,9 +117,24 @@ Class semCallParams mem_equiv m rm; }. +(** Switch for the semantics of function calls: + - when false, arguments and returned values are truncated to the declared type of the called function; + - when true, arguments and returned values are allowed to be undefined. + +Informally, “direct call” means that passing arguments and returned value does not go through an assignment; +indeed, assignments truncate and fail on undefined values. +*) +Class DirectCall := { + direct_call : bool; +}. + +Definition indirect_c : DirectCall := {| direct_call := false |}. +Definition direct_c : DirectCall := {| direct_call := true |}. + Section SEM. Context + {dc:DirectCall} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} @@ -565,6 +147,13 @@ Context Notation gd := (p_globs P). +Definition get_lvar_i (x: lval) : exec var_i := + if x is Lvar x then ok x else type_error. + +Definition dc_truncate_val t v := + if direct_call then ok v + else truncate_val t v. + Inductive sem : estate -> cmd -> estate -> Prop := | Eskip s : sem s [::] s @@ -579,9 +168,9 @@ with sem_I : estate -> instr -> estate -> Prop := with sem_i : estate -> instr_r -> estate -> Prop := | Eassgn s1 s2 (x:lval) tag ty e v v' : - sem_pexpr gd s1 e = ok v -> + sem_pexpr true gd s1 e = ok v -> truncate_val ty v = ok v' → - write_lval gd x v' s1 = ok s2 -> + write_lval true gd x v' s1 = ok s2 -> sem_i s1 (Cassgn x tag ty e) s2 | Eopn s1 s2 t o xs es: @@ -589,43 +178,43 @@ with sem_i : estate -> instr_r -> estate -> Prop := sem_i s1 (Copn xs t o es) s2 | Esyscall s1 scs m s2 o xs es ves vs: - sem_pexprs gd s1 es = ok ves → + sem_pexprs true gd s1 es = ok ves → exec_syscall s1.(escs) s1.(emem) o ves = ok (scs, m, vs) → - write_lvals gd (with_scs (with_mem s1 m) scs) xs vs = ok s2 → + write_lvals true gd (with_scs (with_mem s1 m) scs) xs vs = ok s2 → sem_i s1 (Csyscall xs o es) s2 | Eif_true s1 s2 e c1 c2 : - sem_pexpr gd s1 e = ok (Vbool true) -> + sem_pexpr true gd s1 e = ok (Vbool true) -> sem s1 c1 s2 -> sem_i s1 (Cif e c1 c2) s2 | Eif_false s1 s2 e c1 c2 : - sem_pexpr gd s1 e = ok (Vbool false) -> + sem_pexpr true gd s1 e = ok (Vbool false) -> sem s1 c2 s2 -> sem_i s1 (Cif e c1 c2) s2 | Ewhile_true s1 s2 s3 s4 a c e c' : sem s1 c s2 -> - sem_pexpr gd s2 e = ok (Vbool true) -> + sem_pexpr true gd s2 e = ok (Vbool true) -> sem s2 c' s3 -> sem_i s3 (Cwhile a c e c') s4 -> sem_i s1 (Cwhile a c e c') s4 | Ewhile_false s1 s2 a c e c' : sem s1 c s2 -> - sem_pexpr gd s2 e = ok (Vbool false) -> + sem_pexpr true gd s2 e = ok (Vbool false) -> sem_i s1 (Cwhile a c e c') s2 | Efor s1 s2 (i:var_i) d lo hi c vlo vhi : - sem_pexpr gd s1 lo = ok (Vint vlo) -> - sem_pexpr gd s1 hi = ok (Vint vhi) -> + sem_pexpr true gd s1 lo = ok (Vint vlo) -> + sem_pexpr true gd s1 hi = ok (Vint vhi) -> sem_for i (wrange d vlo vhi) s1 c s2 -> sem_i s1 (Cfor i (d, lo, hi) c) s2 | Ecall s1 scs2 m2 s2 ii xs f args vargs vs : - sem_pexprs gd s1 args = ok vargs -> + sem_pexprs (~~direct_call) gd s1 args = ok vargs -> sem_call s1.(escs) s1.(emem) f vargs scs2 m2 vs -> - write_lvals gd (with_scs (with_mem s1 m2) scs2) xs vs = ok s2 -> + write_lvals (~~direct_call) gd (with_scs (with_mem s1 m2) scs2) xs vs = ok s2 -> sem_i s1 (Ccall ii xs f args) s2 with sem_for : var_i -> seq Z -> estate -> cmd -> estate -> Prop := @@ -633,7 +222,7 @@ with sem_for : var_i -> seq Z -> estate -> cmd -> estate -> Prop := sem_for i [::] s c s | EForOne s1 s1' s2 s3 i w ws c : - write_var i (Vint w) s1 = ok s1' -> + write_var true i (Vint w) s1 = ok s1' -> sem s1' c s2 -> sem_for i ws s2 c s3 -> sem_for i (w :: ws) s1 c s3 @@ -641,106 +230,16 @@ with sem_for : var_i -> seq Z -> estate -> cmd -> estate -> Prop := with sem_call : syscall_state_t -> mem -> funname -> seq value -> syscall_state_t -> mem -> seq value -> Prop := | EcallRun scs1 m1 scs2 m2 fn f vargs vargs' s0 s1 s2 vres vres' : get_fundef (p_funcs P) fn = Some f -> - mapM2 ErrType truncate_val f.(f_tyin) vargs' = ok vargs -> - init_state f.(f_extra) (p_extra P) ev (Estate scs1 m1 vmap0) = ok s0 -> - write_vars f.(f_params) vargs s0 = ok s1 -> + mapM2 ErrType dc_truncate_val f.(f_tyin) vargs' = ok vargs -> + init_state f.(f_extra) (p_extra P) ev (Estate scs1 m1 Vm.init) = ok s0 -> + write_vars (~~direct_call) f.(f_params) vargs s0 = ok s1 -> sem s1 f.(f_body) s2 -> - mapM (fun (x:var_i) => get_var s2.(evm) x) f.(f_res) = ok vres -> - mapM2 ErrType truncate_val f.(f_tyout) vres = ok vres' -> + mapM (fun (x:var_i) => get_var (~~direct_call) s2.(evm) x) f.(f_res) = ok vres -> + mapM2 ErrType dc_truncate_val f.(f_tyout) vres = ok vres' -> scs2 = s2.(escs) -> m2 = finalize f.(f_extra) s2.(emem) -> sem_call scs1 m1 fn vargs' scs2 m2 vres'. -Lemma semE s c s' : - sem s c s' -> - match c with - | [::] => s' = s - | i :: c' => exists si, sem_I s i si /\ sem si c' s' - end. -Proof. by case; eauto. Qed. - -Lemma sem_IE s i s' : - sem_I s i s' -> - let 'MkI ii r := i in - sem_i s r s'. -Proof. by case. Qed. - -Lemma sem_iE s i s' : - sem_i s i s' -> - match i with - | Cassgn lv _ ty e => - ∃ v v', - [/\ sem_pexpr gd s e = ok v, truncate_val ty v = ok v' & write_lval gd lv v' s = ok s' ] - | Copn lvs _ op es => sem_sopn gd op s lvs es = ok s' - | Csyscall xs o es => - ∃ scs m ves vs, - [/\ sem_pexprs gd s es = ok ves, - exec_syscall s.(escs) s.(emem) o ves = ok (scs, m, vs) & - write_lvals gd (with_scs (with_mem s m) scs) xs vs = ok s'] - | Cif e th el => - ∃ b, sem_pexpr gd s e = ok (Vbool b) ∧ sem s (if b then th else el) s' - | Cfor i (d, lo, hi) c => - ∃ vlo vhi, - [/\ sem_pexpr gd s lo = ok (Vint vlo), sem_pexpr gd s hi = ok (Vint vhi) & - sem_for i (wrange d vlo vhi) s c s' ] - | Cwhile a c e c' => - ∃ si b, - [/\ sem s c si, sem_pexpr gd si e = ok (Vbool b) & - if b then ∃ sj, sem si c' sj ∧ sem_i sj (Cwhile a c e c') s' else si = s' ] - | Ccall _ xs f es => - ∃ vs scs2 m2 rs, - [/\ sem_pexprs gd s es = ok vs, - sem_call s.(escs) s.(emem) f vs scs2 m2 rs & - write_lvals gd (with_scs (with_mem s m2) scs2) xs rs = ok s'] - end. -Proof. - case => {s i s'} //. - - by move => s s' x _ ty e v v' hv hv' hw; exists v, v'. - - by move => s scs m s' xs o es ves vs h1 h2 h3; exists scs, m, ves, vs. - - by move => s s' e th el he hth; exists true. - - by move => s s' e th el he hel; exists false. - - by move => s si sj s' c e c' hc he hc' hrec; exists si, true; constructor => //; exists sj. - - by move => s s' c e c' hc he; exists s', false. - - by move => s s' i d lo hi c vlo vhi hlo hhi hc; exists vlo, vhi. - by move => s scs m s' _ xs f es vs rs hvs h hrs; exists vs, scs, m, rs. -Qed. - -Lemma sem_forE i ws s c s' : - sem_for i ws s c s' → - if ws is w :: ws then - exists s1 s2, - [/\ - write_var i (Vint w) s = ok s1, - sem s1 c s2 & - sem_for i ws s2 c s' ] - else s' = s. -Proof. - case => { i ws s c s' } // s s1 s2 s' i w ws c ok_s1 exec_c ih. - by exists s1, s2. -Qed. - -Lemma sem_callE scs1 m1 fn vargs' scs2 m2 vres' : - sem_call scs1 m1 fn vargs' scs2 m2 vres' -> - ∃ f, - get_fundef (p_funcs P) fn = Some f ∧ - ∃ vargs s0 s1 s2 vres, - [/\ - mapM2 ErrType truncate_val f.(f_tyin) vargs' = ok vargs, - init_state f.(f_extra) (p_extra P) ev (Estate scs1 m1 vmap0) = ok s0 /\ - write_vars f.(f_params) vargs s0 = ok s1, - sem s1 f.(f_body) s2, - mapM (fun (x:var_i) => get_var s2.(evm) x) f.(f_res) = ok vres /\ - mapM2 ErrType truncate_val f.(f_tyout) vres = ok vres' & - scs2 = s2.(escs) /\ m2 = finalize f.(f_extra) s2.(emem) ]. -Proof. - case => { scs1 m1 fn vargs' scs2 m2 vres' } scs1 m1 scs2 m2 fn f vargs vargs' s0 s1 s2 vres vres'. - move => hf ha hi hw hc hr ht hscs hfi. - exists f; split => //. - by exists vargs, s0, s1, s2, vres. -Qed. - -(* -------------------------------------------------------------------- *) - Section SEM_IND. Variables (Pc : estate -> cmd -> estate -> Prop) @@ -769,9 +268,9 @@ Section SEM_IND. Definition sem_Ind_assgn : Prop := forall (s1 s2 : estate) (x : lval) (tag : assgn_tag) ty (e : pexpr) v v', - sem_pexpr gd s1 e = ok v → + sem_pexpr true gd s1 e = ok v → truncate_val ty v = ok v' → - write_lval gd x v' s1 = ok s2 → + write_lval true gd x v' s1 = ok s2 → Pi_r s1 (Cassgn x tag ty e) s2. Definition sem_Ind_opn : Prop := @@ -781,32 +280,32 @@ Section SEM_IND. Definition sem_Ind_syscall : Prop := forall s1 scs m s2 o xs es ves vs, - sem_pexprs gd s1 es = ok ves → + sem_pexprs true gd s1 es = ok ves → exec_syscall s1.(escs) s1.(emem) o ves = ok (scs, m, vs) → - write_lvals gd (with_scs (with_mem s1 m) scs) xs vs = ok s2 → + write_lvals true gd (with_scs (with_mem s1 m) scs) xs vs = ok s2 → Pi_r s1 (Csyscall xs o es) s2. Definition sem_Ind_if_true : Prop := forall (s1 s2 : estate) (e : pexpr) (c1 c2 : cmd), - sem_pexpr gd s1 e = ok (Vbool true) -> + sem_pexpr true gd s1 e = ok (Vbool true) -> sem s1 c1 s2 -> Pc s1 c1 s2 -> Pi_r s1 (Cif e c1 c2) s2. Definition sem_Ind_if_false : Prop := forall (s1 s2 : estate) (e : pexpr) (c1 c2 : cmd), - sem_pexpr gd s1 e = ok (Vbool false) -> + sem_pexpr true gd s1 e = ok (Vbool false) -> sem s1 c2 s2 -> Pc s1 c2 s2 -> Pi_r s1 (Cif e c1 c2) s2. Definition sem_Ind_while_true : Prop := forall (s1 s2 s3 s4 : estate) a (c : cmd) (e : pexpr) (c' : cmd), sem s1 c s2 -> Pc s1 c s2 -> - sem_pexpr gd s2 e = ok (Vbool true) -> + sem_pexpr true gd s2 e = ok (Vbool true) -> sem s2 c' s3 -> Pc s2 c' s3 -> sem_i s3 (Cwhile a c e c') s4 -> Pi_r s3 (Cwhile a c e c') s4 -> Pi_r s1 (Cwhile a c e c') s4. Definition sem_Ind_while_false : Prop := forall (s1 s2 : estate) a (c : cmd) (e : pexpr) (c' : cmd), sem s1 c s2 -> Pc s1 c s2 -> - sem_pexpr gd s2 e = ok (Vbool false) -> + sem_pexpr true gd s2 e = ok (Vbool false) -> Pi_r s1 (Cwhile a c e c') s2. Hypotheses @@ -822,8 +321,8 @@ Section SEM_IND. Definition sem_Ind_for : Prop := forall (s1 s2 : estate) (i : var_i) (d : dir) (lo hi : pexpr) (c : cmd) (vlo vhi : Z), - sem_pexpr gd s1 lo = ok (Vint vlo) -> - sem_pexpr gd s1 hi = ok (Vint vhi) -> + sem_pexpr true gd s1 lo = ok (Vint vlo) -> + sem_pexpr true gd s1 hi = ok (Vint vhi) -> sem_for i (wrange d vlo vhi) s1 c s2 -> Pfor i (wrange d vlo vhi) s1 c s2 -> Pi_r s1 (Cfor i (d, lo, hi) c) s2. @@ -833,7 +332,7 @@ Section SEM_IND. Definition sem_Ind_for_cons : Prop := forall (s1 s1' s2 s3 : estate) (i : var_i) (w : Z) (ws : seq Z) (c : cmd), - write_var i w s1 = Ok error s1' -> + write_var true i w s1 = Ok error s1' -> sem s1' c s2 -> Pc s1' c s2 -> sem_for i ws s2 c s3 -> Pfor i ws s2 c s3 -> Pfor i (w :: ws) s1 c s3. @@ -847,10 +346,10 @@ Section SEM_IND. forall (s1 : estate) (scs2 : syscall_state_t) (m2 : mem) (s2 : estate) (ii : inline_info) (xs : lvals) (fn : funname) (args : pexprs) (vargs vs : seq value), - sem_pexprs gd s1 args = ok vargs → + sem_pexprs (~~direct_call) gd s1 args = ok vargs → sem_call (escs s1) (emem s1) fn vargs scs2 m2 vs → Pfun (escs s1) (emem s1) fn vargs scs2 m2 vs → - write_lvals gd (with_scs (with_mem s1 m2) scs2) xs vs = ok s2 → + write_lvals (~~direct_call) gd (with_scs (with_mem s1 m2) scs2) xs vs = ok s2 → Pi_r s1 (Ccall ii xs fn args) s2. Definition sem_Ind_proc : Prop := @@ -858,13 +357,13 @@ Section SEM_IND. (fn:funname) (f : fundef) (vargs vargs': seq value) (s0 s1 s2: estate) (vres vres': seq value), get_fundef (p_funcs P) fn = Some f -> - mapM2 ErrType truncate_val f.(f_tyin) vargs' = ok vargs -> - init_state f.(f_extra) (p_extra P) ev (Estate scs1 m1 vmap0) = ok s0 -> - write_vars (f_params f) vargs s0 = ok s1 -> + mapM2 ErrType dc_truncate_val f.(f_tyin) vargs' = ok vargs -> + init_state f.(f_extra) (p_extra P) ev (Estate scs1 m1 Vm.init) = ok s0 -> + write_vars (~~direct_call) (f_params f) vargs s0 = ok s1 -> sem s1 (f_body f) s2 -> Pc s1 (f_body f) s2 -> - mapM (fun x : var_i => get_var s2.(evm) x) (f_res f) = ok vres -> - mapM2 ErrType truncate_val f.(f_tyout) vres = ok vres' -> + mapM (fun x : var_i => get_var (~~direct_call) s2.(evm) x) (f_res f) = ok vres -> + mapM2 ErrType dc_truncate_val f.(f_tyout) vres = ok vres' -> scs2 = s2.(escs) -> m2 = finalize f.(f_extra) s2.(emem) -> Pfun scs1 m1 fn vargs' scs2 m2 vres'. @@ -876,18 +375,21 @@ Section SEM_IND. Fixpoint sem_Ind (e : estate) (l : cmd) (e0 : estate) (s : sem e l e0) {struct s} : Pc e l e0 := - match s in (sem e1 l0 e2) return (Pc e1 l0 e2) with - | Eskip s0 => Hnil s0 + match s in sem e1 l0 e2 return Pc e1 l0 e2 with + | @Eskip s0 => Hnil s0 | @Eseq s1 s2 s3 i c s0 s4 => @Hcons s1 s2 s3 i c s0 (@sem_I_Ind s1 i s2 s0) s4 (@sem_Ind s2 c s3 s4) end with sem_i_Ind (e : estate) (i : instr_r) (e0 : estate) (s : sem_i e i e0) {struct s} : Pi_r e i e0 := - match s in (sem_i e1 i0 e2) return (Pi_r e1 i0 e2) with - | @Eassgn s1 s2 x tag ty e1 v v' h1 h2 h3 => @Hasgn s1 s2 x tag ty e1 v v' h1 h2 h3 - | @Eopn s1 s2 t o xs es e1 => @Hopn s1 s2 t o xs es e1 - | @Esyscall s1 scs m s2 o xs es ves vs h1 h2 h3 => @Hsyscall s1 scs m s2 o xs es ves vs h1 h2 h3 + match s in sem_i e1 i0 e2 return Pi_r e1 i0 e2 with + | @Eassgn s1 s2 x tag ty e1 v v' h1 h2 h3 => + @Hasgn s1 s2 x tag ty e1 v v' h1 h2 h3 + | @Eopn s1 s2 t o xs es e1 => + @Hopn s1 s2 t o xs es e1 + | @Esyscall s1 scs m s2 o xs es ves vs h1 h2 h3 => + @Hsyscall s1 scs m s2 o xs es ves vs h1 h2 h3 | @Eif_true s1 s2 e1 c1 c2 e2 s0 => @Hif_true s1 s2 e1 c1 c2 e2 s0 (@sem_Ind s1 c1 s2 s0) | @Eif_false s1 s2 e1 c1 c2 e2 s0 => @@ -907,13 +409,13 @@ Section SEM_IND. with sem_I_Ind (e : estate) (i : instr) (e0 : estate) (s : sem_I e i e0) {struct s} : Pi e i e0 := - match s in (sem_I e1 i0 e2) return (Pi e1 i0 e2) with + match s in sem_I e1 i0 e2 return Pi e1 i0 e2 with | @EmkI ii i0 s1 s2 s0 => @HmkI ii i0 s1 s2 s0 (@sem_i_Ind s1 i0 s2 s0) end with sem_for_Ind (v : var_i) (l : seq Z) (e : estate) (l0 : cmd) (e0 : estate) (s : sem_for v l e l0 e0) {struct s} : Pfor v l e l0 e0 := - match s in (sem_for v0 l1 e1 l2 e2) return (Pfor v0 l1 e1 l2 e2) with + match s in sem_for v0 l1 e1 l2 e2 return Pfor v0 l1 e1 l2 e2 with | EForDone s0 i c => Hfor_nil s0 i c | @EForOne s1 s1' s2 s3 i w ws c e1 s0 s4 => @Hfor_cons s1 s1' s2 s3 i w ws c e1 s0 (@sem_Ind s1' c s2 s0) @@ -929,6 +431,245 @@ Section SEM_IND. End SEM_IND. +End SEM. + +(* ** Starting lemmas + * ------------------------------------------------------------------- *) +Lemma type_of_get_global gd g v : + get_global gd g = ok v -> type_of_val v = vtype g. +Proof. by move=> /get_globalI [?[]]. Qed. + +Lemma get_global_defined gd x v : get_global gd x = ok v -> is_defined v. +Proof. by move=> /get_globalI [gv [_ -> _]]; case: gv. Qed. + +Lemma get_gvar_compat wdb gd vm x v : get_gvar wdb gd vm x = ok v -> + (~~wdb || is_defined v) /\ compat_val (vtype x.(gv)) v. +Proof. + rewrite /get_gvar;case:ifP => ? heq. + + by apply: get_var_compat heq. + by rewrite /compat_val (type_of_get_global heq) (get_global_defined heq) orbT. +Qed. + +(* Remark compat_type b = if b then subtype else eq *) +Lemma type_of_get_gvar x gd vm v : + get_gvar true gd vm x = ok v -> + compat_type sw_allowed (type_of_val v) (vtype x.(gv)). +Proof. by move=> /get_gvar_compat [/=hd]; rewrite /compat_val hd orbF. Qed. + +Lemma type_of_get_gvar_sub x gd vm v : + get_gvar true gd vm x = ok v -> + subtype (type_of_val v) (vtype x.(gv)). +Proof. by move=> /type_of_get_gvar /compat_type_subtype. Qed. + +(* We have a more precise result in the non-word cases. *) +Lemma type_of_get_gvar_not_word gd vm x v : + (sw_allowed -> ~ is_sword x.(gv).(vtype)) -> + get_gvar true gd vm x = ok v -> + type_of_val v = x.(gv).(vtype). +Proof. + move=> hnword; rewrite /get_gvar; case: ifP => ?. + + by apply: type_of_get_var_not_word. + by apply type_of_get_global. +Qed. + +Lemma on_arr_varP {syscall_state : Type} {ep : EstateParams syscall_state} + A (f : forall n, WArray.array n -> exec A) wdb v vm x P : + (forall n t, vtype x = sarr n -> + get_var wdb vm x = ok (@Varr n t) -> + f n t = ok v -> P) -> + on_arr_var (get_var wdb vm x) f = ok v -> P. +Proof. + rewrite /on_arr_var=> H;apply: rbindP => vx hx. + have [_] := get_var_compat hx; case: vx hx => // len t h /compat_valE h1. + by apply: H. +Qed. + +Lemma on_arr_gvarP A (f : forall n, WArray.array n -> exec A) wdb v gd s x P: + (forall n t, vtype x.(gv) = sarr n -> + get_gvar wdb gd s x = ok (@Varr n t) -> + f n t = ok v -> P) -> + on_arr_var (get_gvar wdb gd s x) f = ok v -> P. +Proof. + rewrite /get_gvar. + rewrite /on_arr_var=> H;apply: rbindP => vx hx. + have [_] := get_gvar_compat hx; case: vx hx => // len t h /compat_valE h1. + by apply: H. +Qed. + +Lemma get_gvar_glob wdb gd x vm : is_glob x -> get_gvar wdb gd vm x = get_global gd (gv x). +Proof. by rewrite /get_gvar /is_lvar /is_glob => /eqP ->. Qed. + +Lemma get_gvar_nglob wdb gd x vm : ~~is_glob x -> get_gvar wdb gd vm x = get_var wdb vm (gv x). +Proof. by rewrite /get_gvar is_lvar_is_glob => ->. Qed. + +Section WITH_SCS. + + Context + {asm_op syscall_state : Type} + {ep : EstateParams syscall_state} + {spp : SemPexprParams} + (wdb : bool) + (gd : glob_decls) + (s1 : estate) + (scs : syscall_state). + + Let P e : Prop := + sem_pexpr wdb gd s1 e = sem_pexpr wdb gd (with_scs s1 scs) e. + + Let Q es : Prop := + sem_pexprs wdb gd s1 es = sem_pexprs wdb gd (with_scs s1 scs) es. + + Lemma sem_pexpr_es_with_scs : (∀ e, P e) * (∀ es, Q es). + Proof. + apply: pexprs_ind_pair; split; subst P Q => //=; rewrite /sem_pexprs => *; + repeat match goal with H: _ = _ |- _ => rewrite H // end. + Qed. + + Definition sem_pexpr_with_scs := fst sem_pexpr_es_with_scs. + Definition sem_pexprs_with_scs := snd sem_pexpr_es_with_scs. + +End WITH_SCS. + +Section EXEC_ASM. + +Context + {asm_op syscall_state : Type} + {ep : EstateParams syscall_state} + {spp : SemPexprParams} + {asmop : asmOp asm_op}. + +Lemma sopn_toutP o vs vs' : exec_sopn o vs = ok vs' -> + List.map type_of_val vs' = sopn_tout o. +Proof. + rewrite /exec_sopn /sopn_tout /sopn_sem. + t_xrbindP => p _ <-;apply type_of_val_ltuple. +Qed. + +Lemma sopn_tinP o vs vs' : exec_sopn o vs = ok vs' -> + all2 subtype (sopn_tin o) (List.map type_of_val vs). +Proof. + rewrite /exec_sopn /sopn_tin /sopn_sem. + case (get_instr_desc o) => /= _ tin _ tout _ semi _ _. + t_xrbindP => p hp _. + elim: tin vs semi hp => /= [ | t tin hrec] [ | v vs] // semi. + by t_xrbindP => sv /= /of_val_subtype -> /hrec. +Qed. + +End EXEC_ASM. + +(* ** Instructions + * -------------------------------------------------------------------- *) + + +Section SEM. + +Context + {dc:DirectCall} + {asm_op syscall_state : Type} + {ep : EstateParams syscall_state} + {spp : SemPexprParams} + {sip : SemInstrParams asm_op syscall_state} + {T : eqType} + {pT : progT T} + {scP : semCallParams} + (P : prog) + (ev : extra_val_t). + +Notation gd := (p_globs P). +Notation sem := (sem P ev). +Notation sem_i := (sem_i P ev). +Notation sem_I := (sem_I P ev). +Notation sem_for := (sem_for P ev). +Notation sem_call := (sem_call P ev). + +Lemma semE s c s' : + sem s c s' -> + match c with + | [::] => s' = s + | i :: c' => exists si, sem_I s i si /\ sem si c' s' + end. +Proof. by case; eauto. Qed. + +Lemma sem_IE s i s' : + sem_I s i s' -> + let 'MkI ii r := i in + sem_i s r s'. +Proof. by case. Qed. + +Lemma sem_iE s i s' : + sem_i s i s' -> + match i with + | Cassgn lv _ ty e => + ∃ v v', + [/\ sem_pexpr true gd s e = ok v, truncate_val ty v = ok v' & write_lval true gd lv v' s = ok s' ] + | Copn lvs _ op es => sem_sopn gd op s lvs es = ok s' + | Csyscall xs o es => + ∃ scs m ves vs, + [/\ sem_pexprs true gd s es = ok ves, + exec_syscall s.(escs) s.(emem) o ves = ok (scs, m, vs) & + write_lvals true gd (with_scs (with_mem s m) scs) xs vs = ok s'] + | Cif e th el => + ∃ b, sem_pexpr true gd s e = ok (Vbool b) ∧ sem s (if b then th else el) s' + | Cfor i (d, lo, hi) c => + ∃ vlo vhi, + [/\ sem_pexpr true gd s lo = ok (Vint vlo), sem_pexpr true gd s hi = ok (Vint vhi) & + sem_for i (wrange d vlo vhi) s c s' ] + | Cwhile a c e c' => + ∃ si b, + [/\ sem s c si, sem_pexpr true gd si e = ok (Vbool b) & + if b then ∃ sj, sem si c' sj ∧ sem_i sj (Cwhile a c e c') s' else si = s' ] + | Ccall _ xs f es => + ∃ vs scs2 m2 rs, + [/\ sem_pexprs (~~direct_call) gd s es = ok vs, + sem_call s.(escs) s.(emem) f vs scs2 m2 rs & + write_lvals (~~direct_call) gd (with_scs (with_mem s m2) scs2) xs rs = ok s'] + end. +Proof. + case => {s i s'} //. + - by move => s s' x _ ty e v v' hv hv' hw; exists v, v'. + - by move => s scs m s' xs o es ves vs h1 h2 h3; exists scs, m, ves, vs. + - by move => s s' e th el he hth; exists true. + - by move => s s' e th el he hel; exists false. + - by move => s si sj s' c e c' hc he hc' hrec; exists si, true; constructor => //; exists sj. + - by move => s s' c e c' hc he; exists s', false. + - by move => s s' i d lo hi c vlo vhi hlo hhi hc; exists vlo, vhi. + by move => s scs m s' _ xs f es vs rs hvs h hrs; exists vs, scs, m, rs. +Qed. + +Lemma sem_forE i ws s c s' : + sem_for i ws s c s' → + if ws is w :: ws then + exists s1 s2, + [/\ + write_var true i (Vint w) s = ok s1, + sem s1 c s2 & + sem_for i ws s2 c s' ] + else s' = s. +Proof. + case => { i ws s c s' } // s s1 s2 s' i w ws c ok_s1 exec_c ih. + by exists s1, s2. +Qed. + +Lemma sem_callE scs1 m1 fn vargs' scs2 m2 vres' : + sem_call scs1 m1 fn vargs' scs2 m2 vres' -> + ∃ f, + get_fundef (p_funcs P) fn = Some f ∧ + ∃ vargs s0 s1 s2 vres, + [/\ + mapM2 ErrType dc_truncate_val f.(f_tyin) vargs' = ok vargs, + init_state f.(f_extra) (p_extra P) ev (Estate scs1 m1 Vm.init) = ok s0 /\ + write_vars (~~direct_call) f.(f_params) vargs s0 = ok s1, + sem s1 f.(f_body) s2, + mapM (fun (x:var_i) => get_var (~~direct_call) s2.(evm) x) f.(f_res) = ok vres /\ + mapM2 ErrType dc_truncate_val f.(f_tyout) vres = ok vres' & + scs2 = s2.(escs) /\ m2 = finalize f.(f_extra) s2.(emem) ]. +Proof. + case => { scs1 m1 fn vargs' scs2 m2 vres' } scs1 m1 scs2 m2 fn f vargs vargs' s0 s1 s2 vres vres'. + move => hf ha hi hw hc hr ht hscs hfi. + exists f; split => //. + by exists vargs, s0, s1, s2, vres. +Qed. + Lemma sem_app l1 l2 s1 s2 s3: sem s1 l1 s2 -> sem s2 l2 s3 -> sem s1 (l1 ++ l2) s3. @@ -965,196 +706,241 @@ Context {ep : EstateParams syscall_state} {spp : SemPexprParams}. -Lemma on_arr_varP A (f : forall n, WArray.array n -> exec A) v vm x P: - (forall n t, vtype x = sarr n -> get_var vm x = ok (@Varr n t) -> - f n t = ok v -> P) -> - on_arr_var (get_var vm x) f = ok v -> P. +Definition write_var_Spec (wdb : bool) (x : var) (v : value) (s : estate) (s' : estate) : Prop := + [/\ s' = with_vm s (evm s).[x <- v], + DB wdb v & truncatable wdb (vtype x) v]. + +Definition write_get_var_Spec (wdb : bool) (x : var_i) (v : value) (s : estate) (s' : estate) : Prop := + [/\ DB wdb v, truncatable wdb (vtype x) v & + (forall y, get_var wdb (evm s') y = + if v_var x == y then + Let _:= assert (~~wdb || is_defined v) ErrAddrUndef in ok (vm_truncate_val (vtype x) v) + else get_var wdb (evm s) y)]. + +Definition write_get_gvar_Spec gd (wdb : bool) (x : var_i) (v : value) (s : estate) (s' : estate) : Prop := + [/\ DB wdb v, truncatable wdb (vtype x) v & + (forall y, get_gvar wdb gd (evm s') y = + if is_lvar y && (v_var x == gv y) then + Let _:= assert (~~wdb || is_defined v) ErrAddrUndef in ok (vm_truncate_val (vtype x) v) + else get_gvar wdb gd (evm s) y)]. + +Lemma get_var_set wdb vm x v y : + truncatable wdb (vtype x) v -> + get_var wdb vm.[x <- v] y = + if x == y then + Let _ := assert (~~wdb || is_defined v) ErrAddrUndef in ok (vm_truncate_val (vtype x) v) + else get_var wdb vm y. +Proof. by rewrite {1}/get_var Vm.setP; case: eqP => // *; rewrite -vm_truncate_val_defined. Qed. + +Lemma get_var_eq wdb x vm v : + truncatable wdb (vtype x) v -> + get_var wdb vm.[x <- v] x = + Let _ := assert (~~wdb || is_defined v) ErrAddrUndef in ok (vm_truncate_val (vtype x) v). +Proof. by move=> h; rewrite get_var_set // eqxx. Qed. + +Lemma get_var_neq wdb x y vm v : x <> y -> get_var wdb vm.[x <- v] y = get_var wdb vm y. +Proof. by move=> hne; rewrite /get_var Vm.setP_neq //; apply /eqP. Qed. + +Lemma get_var_set_eq wdb vm1 vm2 (x y : var) v: + get_var wdb vm1 y = get_var wdb vm2 y -> + get_var wdb vm1.[x <- v] y = get_var wdb vm2.[x <- v] y. +Proof. by rewrite /get_var !Vm.setP; case: eqP. Qed. + +Lemma get_gvar_eq wdb gd x vm v : + truncatable wdb (vtype (gv x)) v -> + ~ is_glob x -> + get_gvar wdb gd vm.[x.(gv) <- v] x = + Let _ := assert (~~wdb || is_defined v) ErrAddrUndef in ok (vm_truncate_val (vtype (gv x)) v). +Proof. + by move=> h1 /negP h2; rewrite /get_gvar is_lvar_is_glob h2 get_var_eq. +Qed. + +Lemma get_gvar_neq wdb gd (x:var) y vm v : + (~ is_glob y -> x <> (gv y)) -> get_gvar wdb gd vm.[x <- v] y = get_gvar wdb gd vm y. Proof. - rewrite /on_arr_var /= => H; t_xrbindP => vx. - case: x H => -[ | | n | sz ] /= nx;rewrite /get_var /= => H; - (case Heq : (vm.[_])%vmap => [v' | e] /=; last by case: (e) => // -[<-]); - try by move=> [<-]. - by move=> [<-]; apply: H => //=; rewrite Heq /=. + move=> h; rewrite /get_gvar is_lvar_is_glob. + by case: negP => // hg; rewrite get_var_neq //; apply h. Qed. -Lemma on_arr_gvarP A (f : forall n, WArray.array n -> exec A) v gd vm x P0: - (forall n t, vtype x.(gv) = sarr n -> - get_gvar gd vm x = ok (@Varr n t) -> - f n t = ok v -> P0) -> - on_arr_var (get_gvar gd vm x) f = ok v -> P0. +Lemma write_var_truncate wdb (x:var_i) v : + DB wdb v -> truncatable wdb (vtype x) v -> + forall s, write_var wdb x v s = ok (with_vm s (evm s).[x <- v]). +Proof. by move=> hdb htr s; rewrite /write_var (set_var_truncate hdb htr). Qed. + +Lemma write_varP wdb x v s s': + write_var wdb x v s = ok s' <-> write_var_Spec wdb x v s s'. Proof. - rewrite /get_gvar; case: ifP => heq; first by apply: on_arr_varP. - move=> H; apply: rbindP => vx hx. - have h := type_of_get_global hx; case: vx h hx => // len t h. - by apply: H;rewrite -h. + split. + + by rewrite /write_var; t_xrbindP => vm' /set_varP [??->] ?; econstructor; eauto. + by move=> [-> hdb htr]; rewrite write_var_truncate. Qed. -Lemma ok_word_inj E sz sz' w w' : - ok (@Vword sz w) = Ok E (@Vword sz' w') → - ∃ e : sz = sz', eq_rect sz word w sz' e = w'. -Proof. by move => h; have /Vword_inj := ok_inj h. Qed. +Lemma write_varP_arr x len (a:WArray.array len) s s': + write_var true x (Varr a) s = ok s' -> + [/\ type_of_val (Varr a) = vtype x, + truncatable true (vtype x) (Varr a), + vm_truncate_val (vtype x) (Varr a) = Varr a & + s' = with_vm s (evm s).[x <- (Varr a)]]. +Proof. move=> /write_varP [-> hdb /vm_truncate_valE [-> ?]] => //. Qed. -Lemma truncate_pto_val ty v v': - truncate_val ty (@pto_val ty v) = ok v' → - v' = pto_val v. +Lemma write_var_spec wdb x v s1 s2 s1': + write_var wdb x v s1 = ok s2 -> + exists vmx, [/\ write_var wdb x v s1' = ok (with_vm s1' vmx), + evm s1' =[\ Sv.singleton x] vmx & vmx.[x] = (evm s2).[x]]. Proof. -case: ty v. -+ by move=> ? [<-]. + by move=> ? [<-]. -+ by move=> p t1; rewrite /truncate_val /= WArray.castK /= => -[<-]. -move => w [] // s v /= hle; apply: rbindP => w' /truncate_wordP [hle'] -> [<-]. -by rewrite -(cmp_le_antisym hle hle') zero_extend_u. + rewrite /write_var; t_xrbindP => vm hs <-{s2}. + by have [vmx [-> ?? /=]] := set_var_spec (evm s1') hs; exists vmx. Qed. -Lemma is_wconstP gd s sz e w: - is_wconst sz e = Some w → - sem_pexpr gd s e >>= to_word sz = ok w. -Proof. - case: e => // - [] // sz' e /=; case: ifP => // hle /oseq.obindI [z] [h] [<-]. - have := is_constP e; rewrite h => {h} /is_reflect_some_inv -> {e}. - by rewrite /= truncate_word_le. -Qed. +Lemma write_var_eq_type wdb (x:var_i) v: + type_of_val v = vtype x -> DB wdb v -> + forall s, write_var wdb x v s = ok (with_vm s (evm s).[x <- v]). +Proof. move=> h ?; apply/write_var_truncate => //; rewrite -h; apply truncatable_type_of. Qed. -Lemma is_wconstI ws e w : - is_wconst ws e = Some w -> - exists ws' z, e = Papp1 (Oword_of_int ws') (Pconst z). -Proof. - case: e => //. - move=> [] //= ? e. - case: (_ <= _)%CMP; last done. - case: e => //. - by eexists; eexists. -Qed. +Lemma write_get_varP wdb x v s s': + write_var wdb x v s = ok s' -> write_get_var_Spec wdb x v s s'. +Proof. by move=> /write_varP [-> hdb htr]; econstructor; eauto => y /=; rewrite get_var_set. Qed. + +Lemma write_getP_eq wdb (x:var_i) v s s': + write_var wdb x v s = ok s' -> + [/\ DB wdb v, truncatable wdb (vtype x) v & + (evm s').[x] = (vm_truncate_val (vtype x) v)]. +Proof. by move=> /write_varP => -[-> -> ->]; rewrite Vm.setP_eq. Qed. + +Lemma write_getP_neq wdb (x:var_i) v s s' y: v_var x != y -> + write_var wdb x v s = ok s' -> (evm s').[y] = (evm s).[y]. +Proof. by move=> hne /write_varP => -[-> ??]; rewrite Vm.setP_neq. Qed. -Lemma size_wrange d z1 z2 : - size (wrange d z1 z2) = Z.to_nat (z2 - z1). -Proof. by case: d => /=; rewrite ?size_rev size_map size_iota. Qed. +Lemma write_get_varP_eq wdb (x:var_i) v s s': + write_var wdb x v s = ok s' -> + [/\ DB wdb v, truncatable wdb (vtype x) v & + get_var wdb (evm s') x = + Let _ := assert (~~wdb || is_defined v) ErrAddrUndef in ok (vm_truncate_val (vtype x) v)]. +Proof. by move=> /write_get_varP [? ? ->]; rewrite eqxx. Qed. -Lemma nth_wrange z0 d z1 z2 n : (n < Z.to_nat (z2 - z1))%nat -> - nth z0 (wrange d z1 z2) n = - if d is UpTo - then z1 + Z.of_nat n - else z2 - Z.of_nat n. +Lemma write_get_varP_neq wdb wdb' (x:var_i) v s s' y: v_var x != y -> + write_var wdb x v s = ok s' -> get_var wdb' (evm s') y = get_var wdb' (evm s) y. +Proof. rewrite /get_var => hne /write_varP => -[-> ??]; rewrite Vm.setP_neq //. Qed. + +Lemma write_get_gvarP gd wdb x v s s': + write_var wdb x v s = ok s' -> write_get_gvar_Spec gd wdb x v s s'. Proof. -case: d => ltn /=; - by rewrite (nth_map 0%nat) ?size_iota ?nth_iota. + move=> /write_get_varP [hdb htr hget]; econstructor; eauto => y. + by rewrite /get_gvar hget; case: is_lvar. Qed. -Lemma last_wrange_up_ne z0 lo hi : - lo < hi -> last z0 (wrange UpTo lo hi) = hi - 1. +Lemma write_get_gvarP_eq wdb gd (x:var_i) v s s': + write_var wdb x v s = ok s' -> + [/\ DB wdb v, truncatable wdb (vtype x) v & + get_gvar wdb gd (evm s') (mk_lvar x) = + Let _ := assert (~~wdb || is_defined v) ErrAddrUndef in ok (vm_truncate_val (vtype x) v)]. +Proof. by move=> /(write_get_gvarP gd) [hdb htr ->]; rewrite /= eqxx. Qed. + +Lemma write_get_gvarP_neq wdb gd (x:var_i) v s s' y: (is_lvar y -> v_var x != gv y) -> + write_var wdb x v s = ok s' -> get_gvar wdb gd (evm s') y = get_gvar wdb gd (evm s) y. Proof. -move=> lt; rewrite -nth_last nth_wrange; last rewrite size_wrange prednK //. -rewrite size_wrange -subn1 Nat2Z.inj_sub; first by rewrite Z2Nat.id; lia. -+ apply/leP/ltP; rewrite -Z2Nat.inj_0; apply Z2Nat.inj_lt; lia. -+ apply/ltP; rewrite -Z2Nat.inj_0; apply Z2Nat.inj_lt; lia. + move=> h /(write_get_gvarP gd) [htr hdb ->]. + by case: is_lvar h => // /(_ erefl) /negbTE ->. Qed. -Lemma last_wrange_up lo hi : last (hi-1) (wrange UpTo lo hi) = hi - 1. +Lemma is_wconstP wdb gd s sz e w: + is_wconst sz e = Some w → + sem_pexpr wdb gd s e >>= to_word sz = ok w. Proof. -case: (Z_lt_le_dec lo hi) => [lt|le]; first by apply: last_wrange_up_ne. -rewrite -nth_last nth_default // size_wrange. -by rewrite [Z.to_nat _](_ : _ = 0%nat) ?Z_to_nat_le0 //; lia. + case: e => // - [] // sz' e /=; case: ifP => // hle /oseq.obindI [z] [h] [<-]. + have := is_constP e; rewrite h => {h} /is_reflect_some_inv -> {e}. + by rewrite /= truncate_word_le. Qed. -Lemma wrange_cons lo hi : lo <= hi -> - lo - 1 :: wrange UpTo lo hi = wrange UpTo (lo - 1) hi. +Lemma is_wconstI ws e w : + is_wconst ws e = Some w -> + exists ws' z, e = Papp1 (Oword_of_int ws') (Pconst z). Proof. -set s1 := wrange _ _ _; set s2 := wrange _ _ _ => /=. -move=> lt; apply/(@eq_from_nth _ 0) => /=. -+ rewrite {}/s1 {}/s2 !size_wrange -Z2Nat.inj_succ; last lia. - by apply: Nat2Z.inj; rewrite !Z2Nat.id; lia. -rewrite {1}/s1 size_wrange; case => [|i]. -+ rewrite /s2 nth_wrange /=; try lia. - by rewrite -Z2Nat.inj_0; apply/leP/Z2Nat.inj_lt; lia. -move=> lti; rewrite -[nth _ (_ :: _) _]/(nth 0 s1 i) {}/s1 {}/s2. -rewrite !nth_wrange; first lia; last first. -+ by apply/leP; move/leP: lti; lia. -apply/leP/Nat2Z.inj_lt; rewrite Z2Nat.id; last lia. -move/leP/Nat2Z.inj_lt: lti; try rewrite -Z2Nat.inj_succ; last lia. -by rewrite Z2Nat.id; lia. + case: e => //. + move=> [] //= ? e. + case: (_ <= _)%CMP; last done. + case: e => //. + by eexists; eexists. Qed. -Lemma vrvP_var (x:var_i) v s1 s2 : - write_var x v s1 = ok s2 -> - s1.(evm) = s2.(evm) [\ Sv.add x Sv.empty]. -Proof. - rewrite /write_var;t_xrbindP => vm. - apply: set_varP => [t | _] => ? <- <- z Hz; - rewrite Fv.setP_neq //; - by move: Hz => /Sv.singleton_spec /nesym /eqP. -Qed. +Lemma vrvP_var wdb (x:var_i) v s1 s2 : + write_var wdb x v s1 = ok s2 -> + s1.(evm) =[\ Sv.singleton x] s2.(evm). +Proof. by rewrite /write_var;t_xrbindP => vm /set_var_eq_ex ? <-. Qed. -Lemma write_noneP s s' ty v: - write_none s ty v = ok s' -> - s' = s /\ - ((exists u, pof_val ty v = ok u) \/ pof_val ty v = undef_error ∧ ty = sbool). -Proof. - apply: on_vuP => [u ? -> | ?]. - + by split => //;left;exists u. - by case:ifPn => // /eqP ? [->];split => //;right. -Qed. +Lemma write_noneP wdb s s' ty v: + write_none wdb s ty v = ok s' -> + [/\ s' = s, truncatable wdb ty v & DB wdb v]. +Proof. by rewrite /write_none; t_xrbindP. Qed. -Lemma vrvP gd (x:lval) v s1 s2 : - write_lval gd x v s1 = ok s2 -> - s1.(evm) = s2.(evm) [\ vrv x]. +Lemma vrvP wdb gd (x:lval) v s1 s2 : + write_lval gd wdb x v s1 = ok s2 -> + s1.(evm) =[\ vrv x] s2.(evm). Proof. case x => /= [ _ ty | ? /vrvP_var| sz y e| aa sz y e | aa sz len y e] //. + by move=> /write_noneP [->]. + by t_xrbindP => ptr yv hyv hptr ptr' ev hev hptr' w hw m hm <-. - + apply: on_arr_varP => n t; case: y => -[] ty yn yi /= -> hget. - apply: rbindP => we;apply: rbindP => ve He Hve. - by apply: rbindP => v0 Hv0;apply rbindP => t' Ht'; apply vrvP_var. - apply: on_arr_varP => n t; case: y => -[] ty yn yi /= -> hget. - apply: rbindP => we;apply: rbindP => ve He Hve. - by apply: rbindP => v0 Hv0;apply rbindP => t' Ht'; apply vrvP_var. + + by apply: on_arr_varP; t_xrbindP => *; apply: vrvP_var; eauto. + by apply: on_arr_varP; t_xrbindP => *; apply: vrvP_var; eauto. Qed. -Lemma vrvsP gd xs vs s1 s2 : - write_lvals gd s1 xs vs = ok s2 -> - s1.(evm) = s2.(evm) [\ vrvs xs]. +Lemma vrvsP wdb gd xs vs s1 s2 : + write_lvals wdb gd s1 xs vs = ok s2 -> + s1.(evm) =[\ vrvs xs] s2.(evm). Proof. elim: xs vs s1 s2 => [|x xs Hrec] [|v vs] s1 s2 //=. + by move=> [<-]. apply: rbindP => s /vrvP Hrv /Hrec Hrvs. - rewrite vrvs_cons; apply: vmap_eq_exceptT. - + by apply: vmap_eq_exceptI Hrv;SvD.fsetdec. - by apply: vmap_eq_exceptI Hrvs;SvD.fsetdec. + rewrite vrvs_cons; apply: eq_exT. + + by apply: eq_exI Hrv;SvD.fsetdec. + by apply: eq_exI Hrvs;SvD.fsetdec. Qed. -Lemma write_var_memP x v s1 s2 : - write_var x v s1 = ok s2 → emem s1 = emem s2. +Lemma write_var_memP wdb x v s1 s2 : + write_var wdb x v s1 = ok s2 → emem s1 = emem s2. Proof. by apply: rbindP=> ?? [] <-. Qed. -Lemma lv_write_memP gd (x:lval) v s1 s2: +Lemma write_vars_memP wdb xs vs a z : + write_vars wdb xs vs a = ok z → + emem a = emem z. +Proof. + elim: xs vs a => [ | x xs ih ] [] //. + - by move => a [<-]. + by move => v vs a /=; t_xrbindP => b /write_var_memP -> /ih. +Qed. + +Lemma lv_write_memP wdb gd (x:lval) v s1 s2: ~~ lv_write_mem x -> - write_lval gd x v s1 = ok s2 -> + write_lval gd wdb x v s1 = ok s2 -> emem s1 = emem s2. Proof. case: x=> //= [v0 t|v0|aa ws v0 p|aa ws len v0 p] _. + by move => /write_noneP [-> _]. + by apply: write_var_memP. - + by apply: on_arr_varP=> n t Ht Hval; t_xrbindP=> ????????; apply: write_var_memP. - by apply on_arr_varP => n t Ht Hval; t_xrbindP => ????????; apply: write_var_memP. + + by apply: on_arr_varP; t_xrbindP=> *; apply: write_var_memP; eauto. + by apply on_arr_varP; t_xrbindP => *; apply: write_var_memP; eauto. Qed. -Lemma write_var_scsP x v s1 s2 : - write_var x v s1 = ok s2 → escs s1 = escs s2. +Lemma write_var_scsP wdb x v s1 s2 : + write_var wdb x v s1 = ok s2 → escs s1 = escs s2. Proof. by apply: rbindP=> ?? [] <-. Qed. -Lemma lv_write_scsP gd (x:lval) v s1 s2: - write_lval gd x v s1 = ok s2 -> +Lemma lv_write_scsP wdb gd (x:lval) v s1 s2: + write_lval gd wdb x v s1 = ok s2 -> escs s1 = escs s2. Proof. case: x=> /= [v0 t|v0|ws x e|aa ws v0 p|aa ws len v0 p]. + by move => /write_noneP [-> _]. + by apply: write_var_scsP. + by t_xrbindP => *; subst s2. - + by apply: on_arr_varP=> n t Ht Hval; t_xrbindP=> ????????; apply: write_var_scsP. - by apply on_arr_varP => n t Ht Hval; t_xrbindP => ????????; apply: write_var_scsP. + + by apply: on_arr_varP; t_xrbindP=> *; apply: write_var_scsP; eauto. + by apply on_arr_varP; t_xrbindP => *; apply: write_var_scsP; eauto. Qed. Section Write. Context + {dc:DirectCall} {sip : SemInstrParams asm_op syscall_state} {T} {pT : progT T} @@ -1163,14 +949,14 @@ Context Variable P : prog. Variable ev : extra_val_t. -Let Pc s1 c s2 := s1.(evm) = s2.(evm) [\ write_c c]. +Let Pc s1 c s2 := s1.(evm) =[\ write_c c] s2.(evm). -Let Pi_r s1 i s2 := s1.(evm) = s2.(evm) [\ write_i i]. +Let Pi_r s1 i s2 := s1.(evm) =[\ write_i i] s2.(evm). -Let Pi s1 i s2 := s1.(evm) = s2.(evm) [\ write_I i]. +Let Pi s1 i s2 := s1.(evm) =[\ write_I i] s2.(evm). Let Pfor x (_ : seq Z) s1 c s2 := - s1.(evm) = s2.(evm) [\ (Sv.union (Sv.singleton x) (write_c c))]. + s1.(evm) =[\ (Sv.union (Sv.singleton x) (write_c c))] s2.(evm). Let Pfun (_ : syscall_state_t) @@ -1183,7 +969,7 @@ Let Pfun True. Lemma writeP c s1 s2 : - sem P ev s1 c s2 -> s1.(evm) = s2.(evm) [\ write_c c]. + sem P ev s1 c s2 -> s1.(evm) =[\ write_c c] s2.(evm). Proof. apply: (sem_Ind @@ -1198,7 +984,7 @@ Proof. + move=> s1 s2 x tag ty e v v' ? hty Hw z. by rewrite write_i_assgn;apply (vrvP Hw). + move=> s1 s2 t o xs es; rewrite /sem_sopn. - case: (Let _ := sem_pexprs _ _ _ in _) => //= vs Hw z. + case: (Let _ := sem_pexprs _ _ _ _ in _) => //= vs Hw z. by rewrite write_i_opn;apply (vrvsP Hw). + move=> s1 scs m s2 x o es ves vs hes hscs hw. by rewrite /Pi_r write_i_syscall; apply (vrvsP hw). @@ -1212,11 +998,11 @@ Proof. + move=> s1 s1' s2 s3 i w ws c Hw _ Hc _ Hf z Hnin. by rewrite (vrvP_var Hw) ?Hc ?Hf //;SvD.fsetdec. move=> s1 scs2 m2 s2 ii xs fn args vargs vs _ _ _ Hw z. - by rewrite write_i_call;apply (vrvsP Hw). + rewrite write_i_call. apply (vrvsP Hw). Qed. Lemma write_IP i s1 s2 : - sem_I P ev s1 i s2 -> s1.(evm) = s2.(evm) [\ write_I i]. + sem_I P ev s1 i s2 -> s1.(evm) =[\ write_I i] s2.(evm). Proof. move=> /sem_seq1 -/writeP. have := write_c_cons i [::]. @@ -1224,77 +1010,89 @@ Proof. Qed. Lemma write_iP i s1 s2 : - sem_i P ev s1 i s2 -> s1.(evm) = s2.(evm) [\ write_i i]. + sem_i P ev s1 i s2 -> s1.(evm) =[\ write_i i] s2.(evm). Proof. by move=> h; have /write_IP := EmkI dummy_instr_info h. Qed. End Write. -Lemma set_var_disjoint_eq_on x s v vm vm' : +Lemma set_var_disjoint_eq_on wdb x s v vm vm' : ~~ Sv.mem x s -> - set_var vm x v = ok vm' -> + set_var wdb vm x v = ok vm' -> vm =[ s ] vm'. Proof. - move=> /Sv_memP hx hsetx y hy. - rewrite (get_set_var y hsetx). - case: eqP => // ?; subst y. - SvD.fsetdec. + move=> /Sv_memP hx /set_varP [_ _ ->] y hy. + by rewrite Vm.setP_neq //; apply /eqP => ?; subst y; apply hx. Qed. -Lemma disjoint_eq_on gd s r s1 s2 v: +Lemma disjoint_eq_on wdb gd s r s1 s2 v: disjoint s (vrv r) -> - write_lval gd r v s1 = ok s2 -> + write_lval wdb gd r v s1 = ok s2 -> s1.(evm) =[s] s2.(evm). Proof. move=> Hd /vrvP H z Hnin;apply H. move:Hd;rewrite /disjoint /is_true Sv.is_empty_spec;SvD.fsetdec. Qed. -Lemma disjoint_eq_ons gd s r s1 s2 v: +Lemma disjoint_eq_ons wdb gd s r s1 s2 v: disjoint s (vrvs r) -> - write_lvals gd s1 r v = ok s2 -> + write_lvals wdb gd s1 r v = ok s2 -> s1.(evm) =[s] s2.(evm). Proof. move=> Hd /vrvsP H z Hnin;apply H. move:Hd;rewrite /disjoint /is_true Sv.is_empty_spec;SvD.fsetdec. Qed. -Lemma get_var_eq_on s vm' vm v: Sv.In v s -> vm =[s] vm' -> get_var vm v = get_var vm' v. -Proof. by move=> Hin Hvm;rewrite /get_var Hvm. Qed. +Lemma get_var_eq_on wdb s vm' vm v: Sv.In v s -> vm =[s] vm' -> get_var wdb vm v = get_var wdb vm' v. +Proof. by move=> hin hvm;rewrite /get_var hvm. Qed. -Lemma get_gvar_eq_on s gd vm' vm v: Sv.Subset (read_gvar v) s -> vm =[s] vm' -> get_gvar gd vm v = get_gvar gd vm' v. -Proof. - rewrite /read_gvar /get_gvar; case: ifP => // _ Hin. +Lemma get_gvar_eq_on wdb s gd vm' vm v: Sv.Subset (read_gvar v) s -> vm =[s] vm' -> + get_gvar wdb gd vm v = get_gvar wdb gd vm' v. +Proof. + rewrite /read_gvar /get_gvar; case: ifP => // _ hin. by apply: get_var_eq_on; SvD.fsetdec. Qed. -Lemma on_arr_var_eq_on s' X s A x (f: ∀ n, WArray.array n → exec A) : +Lemma on_arr_var_eq_on wdb s' X s A x (f: ∀ n, WArray.array n → exec A) : evm s =[X] evm s' -> Sv.In x X -> - on_arr_var (get_var (evm s) x) f = on_arr_var (get_var (evm s') x) f. + on_arr_var (get_var wdb (evm s) x) f = on_arr_var (get_var wdb (evm s') x) f. Proof. - by move=> Heq Hin;rewrite /on_arr_var;rewrite (get_var_eq_on Hin Heq). + by move=> Heq Hin;rewrite /on_arr_var;rewrite (get_var_eq_on _ Hin Heq). Qed. -Lemma on_arr_gvar_eq_on s' gd X s A x (f: ∀ n, WArray.array n → exec A) : +Lemma on_arr_gvar_eq_on wdb s' gd X s A x (f: ∀ n, WArray.array n → exec A) : evm s =[X] evm s' -> Sv.Subset (read_gvar x) X -> - on_arr_var (get_gvar gd (evm s) x) f = on_arr_var (get_gvar gd (evm s') x) f. + on_arr_var (get_gvar wdb gd (evm s) x) f = on_arr_var (get_gvar wdb gd (evm s') x) f. Proof. move=> Heq; rewrite /get_gvar /read_gvar;case:ifP => _ Hin //. - by apply: (on_arr_var_eq_on (X := X)) => //; SvD.fsetdec. + by apply: (on_arr_var_eq_on _ (X := X)) => //; SvD.fsetdec. +Qed. + +Lemma get_var_eq_ex wdb vm1 vm2 X x: + ~Sv.In x X -> + vm1 =[\ X] vm2 -> + get_var wdb vm1 x = get_var wdb vm2 x. +Proof. by move=> Hin Hvm;rewrite /get_var Hvm. Qed. + +Lemma get_gvar_eq_ex wdb gd vm1 vm2 X x: + disjoint (read_gvar x) X -> + vm1 =[\ X] vm2 -> + get_gvar wdb gd vm1 x = get_gvar wdb gd vm2 x. +Proof. + rewrite /read_gvar /get_gvar; case: ifP => // _ /disjointP hin. + apply: get_var_eq_ex; apply hin; SvD.fsetdec. Qed. Section READ_E_ES_EQ_ON. - Context (gd: glob_decls) (s1:estate) (vm': vmap). + Context (wdb : bool) (gd : glob_decls) (s1 : estate) (vm' : Vm.t). -Notation "vm1 '=[' s ']' vm2" := (eq_on s vm1 vm2) (at level 70, vm2 at next level, - format "'[hv ' vm1 =[ s ] '/' vm2 ']'"). Let P e : Prop := ∀ s, evm s1 =[read_e_rec s e] vm' → - sem_pexpr gd s1 e = sem_pexpr gd (with_vm s1 vm') e. + sem_pexpr wdb gd s1 e = sem_pexpr wdb gd (with_vm s1 vm') e. Let Q es : Prop := ∀ s, evm s1 =[read_es_rec s es] vm' → - sem_pexprs gd s1 es = sem_pexprs gd (with_vm s1 vm') es. + sem_pexprs wdb gd s1 es = sem_pexprs wdb gd (with_vm s1 vm') es. Lemma read_e_es_eq_on : (∀ e, P e) * (∀ es, Q es). Proof. @@ -1303,20 +1101,20 @@ Notation "vm1 '=[' s ']' vm2" := (eq_on s vm1 vm2) (at level 70, vm2 at next lev have Heq' : evm s1 =[read_e_rec s e] vm'. + apply: (eq_onI _ Heq); rewrite /= read_esE; SvD.fsetdec. move: rec => /(_ _ Heq') ->. - case: (sem_pexpr _ _ e) => //= v. + case: (sem_pexpr _ _ _ e) => //= v. by move: ih => /(_ _ Heq) ->. - by move=> x s /get_gvar_eq_on -> //; SvD.fsetdec. - move=> aa sz x e He s Heq; rewrite (He _ Heq) => {He}. - rewrite (on_arr_gvar_eq_on (s' := with_vm s1 vm') _ _ Heq) ?read_eE //. + rewrite (on_arr_gvar_eq_on (s' := with_vm s1 vm') _ _ _ Heq) ?read_eE //. by SvD.fsetdec. - move=> aa sz len x e He s Heq; rewrite (He _ Heq) => {He}. - rewrite (on_arr_gvar_eq_on (s' := with_vm s1 vm') _ _ Heq) ?read_eE //. + rewrite (on_arr_gvar_eq_on (s' := with_vm s1 vm') _ _ _ Heq) ?read_eE //. by SvD.fsetdec. - - by move=> sz x e He s Hvm; rewrite (get_var_eq_on _ Hvm) ?(He _ Hvm) // read_eE;SvD.fsetdec. + - by move=> sz x e He s Hvm; rewrite (get_var_eq_on _ _ Hvm) ?(He _ Hvm) // read_eE;SvD.fsetdec. - by move=> op e He s /He ->. - move => op e1 He1 e2 He2 s Heq; rewrite (He1 _ Heq) (He2 s) //. by move=> z Hin; apply Heq; rewrite read_eE; SvD.fsetdec. - - by move => op es Hes s heq; rewrite -!/(sem_pexprs gd s1) (Hes _ heq). + - by move => op es Hes s heq; rewrite -!/(sem_pexprs wdb gd s1) (Hes _ heq). move=> t e He e1 He1 e2 He2 s Heq; rewrite (He _ Heq) (He1 s) ? (He2 s) //. + move=> z Hin;apply Heq;rewrite !read_eE. by move: Hin;rewrite read_eE;SvD.fsetdec. @@ -1326,292 +1124,169 @@ Notation "vm1 '=[' s ']' vm2" := (eq_on s vm1 vm2) (at level 70, vm2 at next lev End READ_E_ES_EQ_ON. -Definition read_e_eq_on gd s vm' s1 e := - (read_e_es_eq_on gd s1 vm').1 e s. +Definition read_e_eq_on wdb gd s vm' s1 e := + (read_e_es_eq_on wdb gd s1 vm').1 e s. -Lemma read_e_eq_on_empty gd vm s e : +Lemma read_e_eq_on_empty wdb gd vm s e : evm s =[ read_e_rec Sv.empty e ] vm - -> sem_pexpr gd s e = sem_pexpr gd (with_vm s vm) e. + -> sem_pexpr wdb gd s e = sem_pexpr wdb gd (with_vm s vm) e. Proof. exact: read_e_eq_on. Qed. -Definition read_es_eq_on gd es s s1 vm' := - (read_e_es_eq_on gd s1 vm').2 es s. +Definition read_es_eq_on wdb gd es s s1 vm' := + (read_e_es_eq_on wdb gd s1 vm').2 es s. -Lemma read_es_eq_on_empty gd es s vm : +Lemma read_es_eq_on_empty wdb gd es s vm : evm s =[ read_es_rec Sv.empty es ] vm - -> sem_pexprs gd s es = sem_pexprs gd (with_vm s vm) es. + -> sem_pexprs wdb gd s es = sem_pexprs wdb gd (with_vm s vm) es. Proof. exact: read_es_eq_on. Qed. -Corollary eq_on_sem_pexpr s' gd s e : - escs s = escs s' → +Corollary eq_on_sem_pexpr wdb s' gd s e : emem s = emem s' → evm s =[read_e e] evm s' → - sem_pexpr gd s e = sem_pexpr gd s' e. -Proof. by move => eq_scs eq_mem /read_e_eq_on -/(_ gd) ->; case: s' eq_scs eq_mem => scs m vm /= <- <-. Qed. + sem_pexpr wdb gd s e = sem_pexpr wdb gd s' e. +Proof. + move=> eq_mem /read_e_eq_on ->; rewrite (sem_pexpr_with_scs _ gd _ (escs s')). + by case: s' eq_mem => /= > <-. +Qed. -Corollary eq_on_sem_pexprs s' gd s es : - escs s = escs s' → +Corollary eq_on_sem_pexprs wdb s' gd s es : emem s = emem s' → evm s =[read_es es] evm s' → - sem_pexprs gd s es = sem_pexprs gd s' es. -Proof. by move => eq_scs eq_mem /read_es_eq_on -/(_ gd) ->; case: s' eq_scs eq_mem => scs m vm /= <- <-. Qed. - -Lemma set_var_eq_on s x v vm1 vm2 vm1': - set_var vm1 x v = ok vm2 -> - vm1 =[s] vm1' -> - exists vm2' : vmap, - vm2 =[Sv.union (Sv.add x Sv.empty) s] vm2' /\ - set_var vm1' x v = ok vm2'. -Proof. - (apply: set_varP;rewrite /set_var) => [t | ->] -> <- hvm /=. - + exists (vm1'.[x <- ok t])%vmap;split => // z hin. - case: (x =P z) => [<- | /eqP Hxz];first by rewrite !Fv.setP_eq. - by rewrite !Fv.setP_neq ?hvm //;move/eqP:Hxz; SvD.fsetdec. - exists (vm1'.[x <- pundef_addr (vtype x)])%vmap;split => // z Hin. - case: (x =P z) => [<- | /eqP Hxz];first by rewrite !Fv.setP_eq. - by rewrite !Fv.setP_neq ?hvm //;move/eqP:Hxz; SvD.fsetdec. -Qed. - -Lemma write_var_eq_on X x v s1 s2 vm1: - write_var x v s1 = ok s2 -> - evm s1 =[X] vm1 -> - exists vm2 : vmap, - evm s2 =[Sv.add x X] vm2 /\ - write_var x v (with_vm s1 vm1) = ok (with_vm s2 vm2). + sem_pexprs wdb gd s es = sem_pexprs wdb gd s' es. Proof. - rewrite /write_var /=;t_xrbindP => vm2 Hset <-. - move=> /(set_var_eq_on Hset) [vm2' [Hvm2 ->]];exists vm2';split=>//=. - by apply: eq_onI Hvm2;SvD.fsetdec. + move=> eq_mem /read_es_eq_on ->; rewrite (sem_pexprs_with_scs _ gd _ (escs s')). + by case: s' eq_mem => /= > <-. Qed. -Lemma write_lval_eq_on gd X x v s1 s2 vm1 : - Sv.Subset (read_rv x) X -> - write_lval gd x v s1 = ok s2 -> - evm s1 =[X] vm1 -> - exists vm2 : vmap, - evm s2 =[Sv.union (vrv x) X] vm2 /\ - write_lval gd x v (with_vm s1 vm1) = ok (with_vm s2 vm2). -Proof. - case:x => [vi ty | x | sz x e | aa sz' x e | aa sz' len x e] /=. - + move=> ? /write_noneP [->];rewrite /write_none=> H ?;exists vm1;split=>//. - by case:H => [[u ->] | [->] ->]. - + move=> _ Hw /(write_var_eq_on Hw) [vm2 [Hvm2 Hx]];exists vm2;split=>//. - by apply: eq_onI Hvm2;SvD.fsetdec. - + rewrite read_eE => Hsub Hsem Hvm;move:Hsem. - rewrite -(get_var_eq_on _ Hvm);last by SvD.fsetdec. - rewrite (get_var_eq_on _ Hvm);last by SvD.fsetdec. - rewrite (@read_e_eq_on gd Sv.empty vm1 s1);first last. - + by apply: eq_onI Hvm;rewrite read_eE;SvD.fsetdec. - apply: rbindP => vx ->;apply: rbindP => ve ->;apply: rbindP => w /= ->. - by apply: rbindP => m /= -> [<-] /=;exists vm1. - + rewrite read_eE=> Hsub Hsem Hvm;move:Hsem. - rewrite (on_arr_var_eq_on (s' := with_vm s1 vm1) _ Hvm); - last by SvD.fsetdec. - rewrite (@read_e_eq_on gd (Sv.add x Sv.empty) vm1) /=;first last. - + by apply: eq_onI Hvm;rewrite read_eE. - apply: on_arr_varP => n t Htx; rewrite /on_arr_var => -> /=. - apply: rbindP => i -> /=;apply: rbindP => ? -> /=;apply: rbindP => ? -> /= h. - have [vm2' [heq hw]]:= write_var_eq_on h Hvm; exists vm2'; split => //. - by apply: eq_onI heq;SvD.fsetdec. - rewrite read_eE=> Hsub Hsem Hvm;move:Hsem. - rewrite (on_arr_var_eq_on (s' := with_vm s1 vm1) _ Hvm); - last by SvD.fsetdec. - rewrite (@read_e_eq_on gd (Sv.add x Sv.empty) vm1) /=;first last. - + by apply: eq_onI Hvm;rewrite read_eE. - apply: on_arr_varP => n t Htx; rewrite /on_arr_var => -> /=. - apply: rbindP => i -> /=;apply: rbindP => ? -> /=;apply: rbindP => ? -> /= h. - have [vm2' [heq hw]]:= write_var_eq_on h Hvm; exists vm2'; split => //. - by apply: eq_onI heq;SvD.fsetdec. -Qed. +Section UseMem. -Lemma write_lvals_eq_on gd X xs vs s1 s2 vm1 : - Sv.Subset (read_rvs xs) X -> - write_lvals gd s1 xs vs = ok s2 -> - evm s1 =[X] vm1 -> - exists vm2 : vmap, - evm s2 =[Sv.union (vrvs xs) X] vm2 /\ - write_lvals gd (with_vm s1 vm1) xs vs = ok (with_vm s2 vm2). +Context (wdb : bool) (s1 s2 : estate) (heq : evm s1 = evm s2). + +Lemma use_memP gd e: + ~~use_mem e -> + sem_pexpr wdb gd s1 e = sem_pexpr wdb gd s2 e. Proof. - elim: xs vs X s1 s2 vm1 => [ | x xs Hrec] [ | v vs] //= X s1 s2 vm1. - + by move=> _ [<-] ?;exists vm1. - rewrite read_rvs_cons => Hsub. - apply: rbindP => s1' Hw Hws /(write_lval_eq_on _ Hw) [ |vm1' [Hvm1' ->]]. - + by SvD.fsetdec. - have [ |vm2 [Hvm2 /= ->]]:= Hrec _ _ _ _ _ _ Hws Hvm1';first by SvD.fsetdec. - by exists vm2;split => //;rewrite vrvs_cons;apply: eq_onI Hvm2;SvD.fsetdec. + apply (pexpr_mut_ind (P := fun e => ~~use_mem e -> sem_pexpr wdb gd s1 e = sem_pexpr wdb gd s2 e) + (Q := fun e => ~~has use_mem e -> sem_pexprs wdb gd s1 e = sem_pexprs wdb gd s2 e)). + split => //= {e}. + + by move=> e hrec es hrecs; rewrite negb_or => /andP [] /hrec -> /hrecs ->. + + by move=> x _; rewrite heq. + + by move=> ?? x e hrec /hrec ->; rewrite heq. + + by move=> ??? x e hrec /hrec ->; rewrite heq. + + by move=> ? e hrec /hrec ->. + + by move=> ? e1 hrec1 e2 hrec2; rewrite negb_or => /andP[] /hrec1 -> /hrec2 ->. + + by move=> ? es; rewrite /sem_pexprs => h/h->. + by move=> ty e he e1 he1 e2 he2; rewrite !negb_or=> /andP[]/andP[] /he-> /he1-> /he2->. Qed. -(* ------------------------------------------ *) +End UseMem. -Lemma subtype_type_of_val t (v:psem_t t): - subtype (type_of_val (pto_val v)) t. +Lemma use_memP_eq_on wdb gd s1 s2 e: + ~~use_mem e -> + evm s1 =[read_e e] evm s2 -> + sem_pexpr wdb gd s1 e = sem_pexpr wdb gd s2 e. Proof. - by case: t v => //= s w; apply pw_proof. + by move=> h1 h2; rewrite (use_memP wdb (s2:= with_vm s2 (evm s1)) _ gd h1) //; apply: eq_on_sem_pexpr. Qed. -Lemma type_of_get_var x vm v : - get_var vm x = ok v -> - subtype (type_of_val v) (x.(vtype)). +(* FIXME this is close to write_var_spec but less specified *) +Lemma write_var_eq_on1 wdb x v s1 s2 vm1: + write_var wdb x v s1 = ok s2 -> + exists2 vm2 : Vm.t, + write_var wdb x v (with_vm s1 vm1) = ok (with_vm s2 vm2) & + evm s2 =[Sv.singleton x] vm2. Proof. - rewrite /get_var; apply : on_vuP => // t _ <-. - by apply subtype_type_of_val. + rewrite /write_var;t_xrbindP => vm2 hset <-. + have [/= -> ? /=] := set_var_eq_on1 vm1 hset; eexists; eauto. + by rewrite !with_vm_idem. Qed. -Lemma type_of_get_gvar x gd vm v : - get_gvar gd vm x = ok v -> - subtype (type_of_val v) (vtype x.(gv)). +Lemma write_var_eq_on wdb X x v s1 s2 vm1: + write_var wdb x v s1 = ok s2 -> + evm s1 =[X] vm1 -> + exists2 vm2 : Vm.t, + write_var wdb x v (with_vm s1 vm1) = ok (with_vm s2 vm2) & + evm s2 =[Sv.add x X] vm2. Proof. - rewrite /get_gvar;case:ifP => ?. - + by apply type_of_get_var. - by move=> heq; rewrite (type_of_get_global heq). + move=> /dup [] /(write_var_eq_on1 vm1) [vm2' hw2 h] hw1 hs. + exists vm2' => //; rewrite SvP.MP.add_union_singleton. + apply: (eq_on_union hs h); [apply: vrvP_var hw1 | apply: vrvP_var hw2]. Qed. -(* We have a more precise result in the non-word cases. *) -Lemma type_of_get_var_not_word vm x v : - ~ is_sword x.(vtype) -> - get_var vm x = ok v -> - type_of_val v = x.(vtype). +Lemma write_lval_eq_on1 wdb gd s1 s2 vm1 x v: + s1.(evm) =[read_rv x] vm1 -> + write_lval wdb gd x v s1 = ok s2 -> + exists2 vm2, + write_lval wdb gd x v (with_vm s1 vm1) = ok (with_vm s2 vm2) & + s2.(evm) =[vrv x] vm2. Proof. - move=> hnword. - rewrite /get_var. - apply: on_vuP => // t _ <-. - by case: x hnword t => -[]. + case:x => [vi ty | x | sz x e | aa sz' x e | aa sz' len x e] /=. + + by move=> _ /write_noneP [-> h1 h2]; rewrite /write_none h1 h2; exists vm1. + + by move=> _ /(write_var_eq_on1 vm1). + + rewrite read_eE => Hvm. + rewrite -(get_var_eq_on wdb _ Hvm); last by SvD.fsetdec. + rewrite (@read_e_eq_on wdb gd Sv.empty vm1 s1);first last. + + by apply: eq_onI Hvm;rewrite read_eE;SvD.fsetdec. + by t_xrbindP => > -> /= -> > -> /= -> ? -> ? /= -> <- /=; exists vm1. + + rewrite read_eE=> Hvm. + rewrite (on_arr_var_eq_on _ (s' := with_vm s1 vm1) _ Hvm); last by SvD.fsetdec. + rewrite (@read_e_eq_on _ gd (Sv.add x Sv.empty) vm1) /=;first last. + + by apply: eq_onI Hvm;rewrite read_eE. + apply: on_arr_varP => n t Htx; rewrite /on_arr_var => -> /=. + by t_xrbindP => > -> /= -> ? -> ? /= -> /= /(write_var_eq_on1 vm1). + rewrite read_eE=> Hvm. + rewrite (on_arr_var_eq_on _ (s' := with_vm s1 vm1) _ Hvm); last by SvD.fsetdec. + rewrite (@read_e_eq_on _ gd (Sv.add x Sv.empty) vm1) /=;first last. + + by apply: eq_onI Hvm;rewrite read_eE. + apply: on_arr_varP => n t Htx; rewrite /on_arr_var => -> /=. + by t_xrbindP => > -> /= -> > -> ? /= -> /(write_var_eq_on1 vm1). Qed. -Lemma type_of_get_gvar_not_word gd vm x v : - ~ is_sword x.(gv).(vtype) -> - get_gvar gd vm x = ok v -> - type_of_val v = x.(gv).(vtype). +Lemma write_lval_eq_on wdb gd X x v s1 s2 vm1 : + Sv.Subset (read_rv x) X -> + write_lval wdb gd x v s1 = ok s2 -> + evm s1 =[X] vm1 -> + exists2 vm2 : Vm.t, + write_lval wdb gd x v (with_vm s1 vm1) = ok (with_vm s2 vm2) & + evm s2 =[Sv.union (vrv x) X] vm2. Proof. - move=> hnword. - rewrite /get_gvar. - case: is_lvar. - + by apply type_of_get_var_not_word. - by apply type_of_get_global. + move=> hsub hw1 heq1. + have [vm2 hw2 heq2]:= write_lval_eq_on1 (eq_onI hsub heq1) hw1. + exists vm2 => //; apply: (eq_on_union heq1 heq2); [apply: vrvP hw1 | apply: vrvP hw2]. Qed. -(* -------------------------------------------- *) - -Lemma pof_val_undef_ok t t' h v: - pof_val t (Vundef t' h) <> ok v. -Proof. by case: t t' h v => //= [||s] []. Qed. - -Lemma value_uincl_pto_val t (vt : psem_t t) v: - pof_val t v = ok vt -> - value_uincl (pto_val vt) v. +Lemma write_lvals_eq_on wdb gd X xs vs s1 s2 vm1 : + Sv.Subset (read_rvs xs) X -> + write_lvals wdb gd s1 xs vs = ok s2 -> + evm s1 =[X] vm1 -> + exists2 vm2 : Vm.t, + write_lvals wdb gd (with_vm s1 vm1) xs vs = ok (with_vm s2 vm2) & + evm s2 =[Sv.union (vrvs xs) X] vm2. Proof. -case: t vt => //=. -by move=> ? /to_boolI ->. -by move=> ? /to_intI ->. -by move=> ?? /to_arrI ->. -move=> ?? /to_pwordI [ws' [w' [-> ->]]]. -case: Sumbool.sumbool_of_bool => //= h. -by apply/word_uincl_zero_ext/cmp_lt_le; rewrite -cmp_nle_lt h. + elim: xs vs X s1 s2 vm1 => [ | x xs Hrec] [ | v vs] //= X s1 s2 vm1. + + by move=> _ [<-] ?;exists vm1. + rewrite read_rvs_cons => Hsub. + t_xrbindP => s1' hw hws /(write_lval_eq_on _ hw) [ |vm1' -> hvm1'] /=; first by SvD.fsetdec. + have [ |vm2 /= -> hvm2]:= Hrec _ _ _ _ _ _ hws hvm1';first by SvD.fsetdec. + exists vm2 => //; rewrite vrvs_cons; apply: eq_onI hvm2;SvD.fsetdec. Qed. -Definition pval_uincl (t1 t2:stype) (v1:psem_t t1) (v2:psem_t t2) := - value_uincl (pto_val v1) (pto_val v2). - -Definition eval_uincl (t1 t2:stype) (v1: exec (psem_t t1)) (v2: exec (psem_t t2)) := - match v1, v2 with - | Ok v1 , Ok v2 => pval_uincl v1 v2 - | Error ErrAddrUndef, Ok _ => True - | Error x, Error y => x = y - | _ , _ => False - end. - -Definition vm_uincl (vm1 vm2:vmap) := - forall x, eval_uincl (vm1.[x])%vmap (vm2.[x])%vmap. - -#[ global ] Arguments vm_uincl _%vmap_scope _%vmap_scope. - -Lemma pval_uincl_refl t v: @pval_uincl t t v v. -Proof. by rewrite /pval_uincl. Qed. -Hint Resolve pval_uincl_refl : core. - -Lemma eval_uincl_refl t v: @eval_uincl t t v v. -Proof. by case: v=> //= -[]. Qed. -Hint Resolve eval_uincl_refl : core. - -Lemma eval_uincl_trans t1 t2 t3 - (v2 : exec (psem_t t2)) (v1: exec (psem_t t1)) (v3: exec (psem_t t3)) : - eval_uincl v1 v2 -> eval_uincl v2 v3 -> eval_uincl v1 v3. -Proof. - case: v1 => /= [v1 | ]. - + by case: v2 => //= v2; case: v3 => // v3;apply: value_uincl_trans. - case: v2 => [v2 [] // _| ];first by case: v3. - by move=> e1 e2 he;have <- : e2 = e1 by case: e2 he. -Qed. - -Lemma vm_uincl_refl vm: @vm_uincl vm vm. -Proof. by done. Qed. -Hint Resolve vm_uincl_refl : core. - -Lemma vm_uincl_trans vm2 vm1 vm3 : - vm_uincl vm1 vm2 → - vm_uincl vm2 vm3 → - vm_uincl vm1 vm3. -Proof. move => A B x; exact: (eval_uincl_trans (A x) (B x)). Qed. - -Lemma pof_val_uincl v v' t z: - value_uincl v v' -> - pof_val t v = ok z -> - exists z', pof_val t v' = ok z' /\ pval_uincl z z'. -Proof. - case: v v'=> [b | n | n a | sz w | tv h] [b' | n' | n' a' | sz' w' | tv' h'] //=; - try by move=> _ /pof_val_undef_ok. - + by move=> <- ?;exists z. - + by move=> <- ?;exists z. - + by move=> hu; case: t z => //= p a1 /(WArray.uincl_cast hu) []; eauto. - move=> /andP []hsz /eqP ->;rewrite /pof_val /pval_uincl /=. - case: t z => //= s z. - case: (Sumbool.sumbool_of_bool (sz ≤ s)%CMP). - + move=> e [<-]. - case: (Sumbool.sumbool_of_bool (sz' ≤ s)%CMP). - + move=> ?; eexists;split;first reflexivity => /=. - by rewrite /word_uincl /= hsz eqxx. - move => /negbT hle; eexists; split; first reflexivity. - by rewrite /word_uincl /= e zero_extend_idem // eqxx. - move => /negbT hlt1 [<-]; eexists; split; first reflexivity. - have hnle: (sz' <= s)%CMP = false. - + apply negbTE; rewrite cmp_nle_lt. - by apply: cmp_lt_le_trans hsz; rewrite -cmp_nle_lt. - have hle := cmp_nle_le hlt1. - by rewrite /= zero_extend_idem // (sumbool_of_boolEF hnle). -Qed. - -Lemma get_var_uincl_at x vm1 vm2 v1 : - (eval_uincl vm1.[x] vm2.[x])%vmap -> - get_var vm1 x = ok v1 -> - exists2 v2, get_var vm2 x = ok v2 & value_uincl v1 v2. -Proof. - rewrite /get_var=> H; apply: on_vuP => //. - move=> z1 Heq1 <-. - move: H;rewrite Heq1=> {Heq1}. - case: (vm2.[x])%vmap => //= z2 Hz2. - by exists (pto_val z2) => //;apply pval_uinclP. -Qed. - -Corollary get_var_uincl x vm1 vm2 v1: - vm_uincl vm1 vm2 -> - get_var vm1 x = ok v1 -> - exists2 v2, get_var vm2 x = ok v2 & value_uincl v1 v2. -Proof. by move => /(_ x); exact: get_var_uincl_at. Qed. +(* -------------------------------------------- *) -Lemma get_gvar_uincl_at x gd vm1 vm2 v1: - (if is_lvar x then eval_uincl vm1.[gv x] vm2.[gv x] else True)%vmap -> - get_gvar gd vm1 x = ok v1 -> - exists2 v2, get_gvar gd vm2 x = ok v2 & value_uincl v1 v2. +Lemma get_gvar_uincl_at wdb x gd vm1 vm2 v1: + (if is_lvar x then value_uincl vm1.[gv x] vm2.[gv x] else True) -> + get_gvar wdb gd vm1 x = ok v1 -> + exists2 v2, get_gvar wdb gd vm2 x = ok v2 & value_uincl v1 v2. Proof. rewrite /get_gvar; case:ifP => _. + exact: get_var_uincl_at. by move=> ? ->;exists v1. Qed. -Corollary get_gvar_uincl x gd vm1 vm2 v1: +Corollary get_gvar_uincl wdb x gd vm1 vm2 v1: vm_uincl vm1 vm2 -> - get_gvar gd vm1 x = ok v1 -> - exists2 v2, get_gvar gd vm2 x = ok v2 & value_uincl v1 v2. + get_gvar wdb gd vm1 x = ok v1 -> + exists2 v2, get_gvar wdb gd vm2 x = ok v2 & value_uincl v1 v2. Proof. by move => /(_ x.(gv)) h; apply: get_gvar_uincl_at; case: ifP. Qed. Lemma vuincl_sem_sop2 o ve1 ve1' ve2 ve2' v1 : @@ -1649,154 +1324,89 @@ Proof. by move => sz n; rewrite /= all_nseq orbT. Qed. -(* --------------------------------------------------------- *) -(* VMAP_UINCL_ON *) -Definition vmap_uincl_on (dom: Sv.t) : relation vmap := - λ vm1 vm2, - ∀ x : var, Sv.In x dom → (eval_uincl vm1.[x] vm2.[x])%vmap. - -Notation "vm1 '<=[' s ']' vm2" := (vmap_uincl_on s vm1 vm2) (at level 70, vm2 at next level, - format "'[hv ' vm1 <=[ s ] '/' vm2 ']'"). - -Lemma vmap_uincl_onT vm2 X vm1 vm3 : - vm1 <=[X] vm2 -> vm2 <=[X] vm3 -> vm1 <=[X] vm3. -Proof. move=> H1 H2 ? hin;apply: eval_uincl_trans (H1 _ hin) (H2 _ hin). Qed. - -Lemma vmap_uincl_onI s1 s2 vm1 vm2 : Sv.Subset s1 s2 -> vm1 <=[s2] vm2 -> vm1 <=[s1] vm2. -Proof. move=> Hs Heq x Hin;apply Heq;SvD.fsetdec. Qed. - -Lemma vmap_uincl_on_refl X vm : vm <=[X] vm. -Proof. done. Qed. - -Global Instance vmap_uincl_on_impl : Proper (Basics.flip Sv.Subset ==> eq ==> eq ==> Basics.impl) - vmap_uincl_on. -Proof. by move=> s1 s2 H vm1 ? <- vm2 ? <-;apply: vmap_uincl_onI. Qed. - -Global Instance vmap_uincl_on_m : Proper (Sv.Equal ==> eq ==> eq ==> iff) vmap_uincl_on. -Proof. by move=> s1 s2 Heq vm1 ? <- vm2 ? <-;split;apply: vmap_uincl_onI;rewrite Heq. Qed. - -Lemma eq_on_uincl_on X vm1 vm2 : vm1 =[X] vm2 -> vm1 <=[X] vm2. -Proof. by move=> H ? /H ->. Qed. - -Lemma vm_uincl_vmap_uincl_on dom vm1 vm2 : - vm_uincl vm1 vm2 → - vmap_uincl_on dom vm1 vm2. -Proof. by move => h x _; exact: h. Qed. - -#[ global ] Instance vmap_uincl_on_trans dom : Transitive (vmap_uincl_on dom). -Proof. move => x y z xy yz r hr; apply: (eval_uincl_trans (xy _ hr)); exact: yz. Qed. - -Lemma vmap_uincl_on_empty vm1 vm2 : - vmap_uincl_on Sv.empty vm1 vm2. -Proof. by move => ?; SvD.fsetdec. Qed. - -Hint Resolve vmap_uincl_on_empty : core. - -Lemma vmap_uincl_on_union dom dom' vm1 vm2 : - vmap_uincl_on (Sv.union dom dom') vm1 vm2 ↔ - vmap_uincl_on dom vm1 vm2 ∧ vmap_uincl_on dom' vm1 vm2. -Proof. - split. - + by move => h; split => x hx; apply: h; SvD.fsetdec. - by case => h h' x /Sv.union_spec[]; [ exact: h | exact: h' ]. -Qed. - -Lemma vmap_uincl_on_vm_uincl vm1 vm2 vm1' vm2' d : - vm_uincl vm1 vm2 → - vmap_uincl_on d vm1' vm2' → - vm1 = vm1' [\ d] → - vm2 = vm2' [\ d] → - vm_uincl vm1' vm2'. -Proof. - move => out on t1 t2 x. - case: (Sv_memP x d); first exact: on. - by move => hx; rewrite -!(t1, t2). -Qed. (* --------------------------------------------------------- *) -Lemma sem_pexpr_uincl_on_rec gd s1 vm2 es vs1 : - vmap_uincl_on (read_es es) s1.(evm) vm2 → - sem_pexprs gd s1 es = ok vs1 → +Lemma sem_pexpr_uincl_on_rec wdb gd s1 vm2 es vs1 : + s1.(evm) <=[read_es es] vm2 → + sem_pexprs wdb gd s1 es = ok vs1 → (∀ e : pexpr, List.In e es → ∀ v1 : value, - vmap_uincl_on (read_e e) (evm s1) vm2 → - sem_pexpr gd s1 e = ok v1 → + s1.(evm) <=[read_e e] vm2 → + sem_pexpr wdb gd s1 e = ok v1 → exists2 v2 : value, - sem_pexpr gd (with_vm s1 vm2) e = ok v2 & + sem_pexpr wdb gd (with_vm s1 vm2) e = ok v2 & value_uincl v1 v2) → exists2 vs2, - sem_pexprs gd (with_vm s1 vm2) es = ok vs2 & + sem_pexprs wdb gd (with_vm s1 vm2) es = ok vs2 & List.Forall2 value_uincl vs1 vs2. Proof. elim: es vs1. + by case => //; eauto. move => e es ih vs1. - rewrite read_es_cons => /vmap_uincl_on_union[] hvm /ih{ih}ih /=. + rewrite read_es_cons => /uincl_on_union_and [] hvm /ih{ih}ih /=. t_xrbindP => v ok_v vs ok_vs <-{vs1} rec. move: ih => /(_ _ ok_vs) []. + by move => e' he'; apply: rec; right. move => vs' ok_vs' hs. - move: rec => /(_ e _ _ hvm ok_v) []. - + by left. + move: rec => /(_ e _ _ hvm ok_v) []; first by left. move => v' ok_v' h. - exists (v' :: vs'). - + by rewrite ok_v' ok_vs'. + exists (v' :: vs'); first by rewrite ok_v' ok_vs'. by constructor. Qed. -Lemma sem_pexpr_uincl_on gd s1 vm2 e v1 : - vmap_uincl_on (read_e e) s1.(evm) vm2 → - sem_pexpr gd s1 e = ok v1 → - exists2 v2, sem_pexpr gd (with_vm s1 vm2) e = ok v2 & value_uincl v1 v2. +Lemma sem_pexpr_uincl_on wdb gd s1 vm2 e v1 : + s1.(evm) <=[read_e e] vm2 → + sem_pexpr wdb gd s1 e = ok v1 → + exists2 v2, sem_pexpr wdb gd (with_vm s1 vm2) e = ok v2 & value_uincl v1 v2. Proof. elim: e v1 => /= > => [|||| Hp v1 | Hp v1 | Hp v1 | Hp v1 | He1 e2 He2 v1 | Hes v1 | He e1 He1 e2 He2 v1]; rewrite /read_e /= ?read_eE ?read_eE /read_gvar; t_xrbindP=> Hu. 1-3: by move=> ->; eauto. + by apply: get_gvar_uincl_at; move: Hu; case: ifP => // _; apply; SvD.fsetdec. - + move: Hu => /vmap_uincl_on_union[] /Hp{Hp}Hp Hu. + + move: Hu => /uincl_on_union_and[] /Hp{Hp}Hp Hu. apply on_arr_gvarP => n t Htx; rewrite /on_arr_var => /get_gvar_uincl_at - /(_ vm2) []. * by move: Hu; case: ifP => // _; apply; SvD.fsetdec. t_xrbindP=> ? -> /value_uinclE [? -> /WArray.uincl_get hg] > /Hp{Hp} [? -> ] /[swap] /to_intI -> /value_uinclE -> ? /hg{hg} /= -> /= ->. by eauto. - + move: Hu => /vmap_uincl_on_union[] /Hp{Hp}Hp Hu. + + move: Hu => /uincl_on_union_and[] /Hp{Hp}Hp Hu. apply on_arr_gvarP => n t Htx; rewrite /on_arr_var => /get_gvar_uincl_at - /(_ vm2) []. * by move: Hu; case: ifP => // _; apply; SvD.fsetdec. t_xrbindP=> ? -> /value_uinclE [? -> /WArray.uincl_get_sub h] > /Hp{Hp} [? -> ] /[swap] /to_intI -> /value_uinclE -> ? /h{h} /= [? -> ?] /= <-. by eauto. - + move: Hu => /vmap_uincl_on_union[] /Hp{Hp}Hp Hu > /get_var_uincl_at - /(_ vm2) []. + + move: Hu => /uincl_on_union_and[] /Hp{Hp}Hp Hu > /get_var_uincl_at - /(_ vm2) []. * by apply: Hu; SvD.fsetdec. move=> ? -> /[swap] /to_wordI [? [? [-> /word_uincl_truncate h]]] /value_uinclE [? [? [-> /h{h} /= ->]]] > /Hp[] ? -> /[swap] /to_wordI[? [? [-> /word_uincl_truncate h]]] /value_uinclE [? [? [-> /h{h} /= ->]]] ? /= -> /= ->. by eauto. - + by move: Hu => /vmap_uincl_on_union[] /Hp{Hp}Hp Hu + + by move: Hu => /uincl_on_union_and[] /Hp{Hp}Hp Hu ve1 /Hp [] ve1' -> /vuincl_sem_sop1 Hvu1 /Hvu1; exists v1. - + by move: Hu => /vmap_uincl_on_union[] /He1{He1}He1 - /vmap_uincl_on_union[] /He2{He2} He2 _ + + by move: Hu => /uincl_on_union_and[] /He1{He1}He1 + /uincl_on_union_and[] /He2{He2} He2 _ ? /He1 [? -> /vuincl_sem_sop2 h1] ? /He2 [? -> /h1 h2/h2]; exists v1. + move=> vs /(fun x => sem_pexpr_uincl_on_rec Hu x Hes) [? ]. by rewrite /sem_pexprs => -> /vuincl_sem_opN h/h. - move: Hu => /vmap_uincl_on_union[] /He{He}He /vmap_uincl_on_union[] - /He1{He1}He1 /vmap_uincl_on_union[] /He2{He2}He2 _ b + move: Hu => /uincl_on_union_and[] /He{He}He /uincl_on_union_and[] + /He1{He1}He1 /uincl_on_union_and[] /He2{He2}He2 _ b > /He[? ->] /[swap] /to_boolI -> /value_uinclE -> ? > /He1[? ->] /value_uincl_truncate h /h{h} [? /= -> ?] > /He2 [? -> /value_uincl_truncate h] /h{h} [? /= -> ?] /= <-. by case: b; eauto. Qed. -Corollary sem_pexpr_uincl gd s1 vm2 e v1 : - vm_uincl s1.(evm) vm2 → - sem_pexpr gd s1 e = ok v1 → - exists2 v2, sem_pexpr gd (with_vm s1 vm2) e = ok v2 & value_uincl v1 v2. -Proof. move => /(@vm_uincl_vmap_uincl_on (read_e e)); exact: sem_pexpr_uincl_on. Qed. +Corollary sem_pexpr_uincl wdb gd s1 vm2 e v1 : + s1.(evm) <=1 vm2 → + sem_pexpr wdb gd s1 e = ok v1 → + exists2 v2, sem_pexpr wdb gd (with_vm s1 vm2) e = ok v2 & value_uincl v1 v2. +Proof. move => /(vm_uincl_uincl_on (dom:=read_e e)); exact: sem_pexpr_uincl_on. Qed. -Lemma sem_pexprs_uincl_on gd s1 vm2 es vs1 : - vmap_uincl_on (read_es es) s1.(evm) vm2 → - sem_pexprs gd s1 es = ok vs1 → - exists2 vs2, sem_pexprs gd (with_vm s1 vm2) es = ok vs2 & +Lemma sem_pexprs_uincl_on wdb gd s1 vm2 es vs1 : + s1.(evm) <=[read_es es] vm2 → + sem_pexprs wdb gd s1 es = ok vs1 → + exists2 vs2, sem_pexprs wdb gd (with_vm s1 vm2) es = ok vs2 & List.Forall2 value_uincl vs1 vs2. Proof. move => heq ok_vs. @@ -1804,193 +1414,116 @@ Proof. exact: sem_pexpr_uincl_on. Qed. -Corollary sem_pexprs_uincl gd s1 vm2 es vs1 : - vm_uincl s1.(evm) vm2 → - sem_pexprs gd s1 es = ok vs1 → - exists2 vs2, sem_pexprs gd (with_vm s1 vm2) es = ok vs2 & +Corollary sem_pexprs_uincl wdb gd s1 vm2 es vs1 : + s1.(evm) <=1 vm2 → + sem_pexprs wdb gd s1 es = ok vs1 → + exists2 vs2, sem_pexprs wdb gd (with_vm s1 vm2) es = ok vs2 & List.Forall2 value_uincl vs1 vs2. -Proof. move => /(@vm_uincl_vmap_uincl_on (read_es es)); exact: sem_pexprs_uincl_on. Qed. - -Lemma vuincl_exec_opn {sip : SemInstrParams asm_op syscall_state} o vs vs' v : - List.Forall2 value_uincl vs vs' -> exec_sopn o vs = ok v -> - exists2 v', exec_sopn o vs' = ok v' & List.Forall2 value_uincl v v'. -Proof. - rewrite /exec_sopn /sopn_sem => vs_vs' ho. - exact: (get_instr_desc o).(semu) vs_vs' ho. -Qed. +Proof. move => /(vm_uincl_uincl_on (dom:=read_es es)); exact: sem_pexprs_uincl_on. Qed. -Lemma set_vm_uincl vm vm' x z z' : - vm_uincl vm vm' -> - eval_uincl z z' -> - vm_uincl vm.[x <- z] vm'.[x <- z']. -Proof. - move=> Hvm Hz y; case( x =P y) => [<- | /eqP Hneq];by rewrite ?Fv.setP_eq ?Fv.setP_neq. -Qed. - -Lemma of_val_error t v: - of_val t v = undef_error -> exists t' h, v = Vundef t' h /\ subtype t t'. -Proof. -case: t v => [||p|sz] [] //=. -+ by case => //; eauto. -+ by case => //; eauto. -+ by move => n a; rewrite /WArray.cast; case: ifPn. -+ by move=> ?? /truncate_word_errP[]. -by case => // sz' e; case: ifP => // *; exists (sword sz'), e. -Qed. - -Lemma pof_val_pto_val t (v:psem_t t): pof_val t (pto_val v) = ok v. -Proof. - case: t v => [b | z | n a | s w] //=. - + by apply WArray.castK. - case: Sumbool.sumbool_of_bool => e. - + f_equal;case: w e => /= ????;f_equal; apply eq_irrelevance. - by have := pw_proof w;rewrite e. -Qed. - -Lemma pto_val_pof_val v t : - pof_val (type_of_val v) v = ok t -> - pto_val t = v. -Proof. - case: v t => /=. - + by move=> ?? [->]. - + by move=> ?? [->]. - + by move=> len a ?; rewrite WArray.castK => -[<-]. - + by move=> ws w pw; rewrite sumbool_of_boolET => -[<-]. - by case. -Qed. - -Lemma value_uincl_pof_val t v1 (v1' v2 : psem_t t): - pof_val t v1 = ok v1' -> - value_uincl v1 (pto_val v2) -> - value_uincl (pto_val v1') (pto_val v2). -Proof. - case: t v1' v2 => [] >. - + by move=> /to_boolI ->. - + by move=> /to_intI ->. - + by move=> /to_arrI ->. - case: v1 => //= [ s' w| [] //] [<-]. - case: Sumbool.sumbool_of_bool => //= /negbT hnle. - have hle := cmp_nle_le hnle; apply: word_uincl_trans. - exact: word_uincl_zero_ext. -Qed. - -Lemma subtype_eval_uincl_pundef t1 t2 : - subtype t1 t2 -> - eval_uincl (pundef_addr t1) (pundef_addr t2). -Proof. - case: t1 => /= [/eqP?|/eqP?|n| s];subst => //=; case: t2 => //=. - by move => ? /eqP [] <-. -Qed. - -Lemma pof_val_bool_undef v : pof_val sbool v = undef_error -> v = undef_b. -Proof. by case: v => //= -[] // e; rewrite (Eqdep_dec.UIP_refl_bool _ e). Qed. - -Lemma pof_val_undef v v': - value_uincl v v' -> - pof_val sbool v = undef_error -> - v' = undef_b \/ exists b, v' = Vbool b. +Lemma sem_pexpr_uincl_on' wdb gd s vm' vm scs m e v1 : + vm <=[read_e_rec s e] vm' -> + sem_pexpr wdb gd {| escs := scs; emem := m; evm := vm |} e = ok v1 -> + exists2 v2 : value, + sem_pexpr wdb gd {| escs := scs; emem := m; evm := vm' |} e = ok v2 & value_uincl v1 v2. Proof. - move=> + /pof_val_bool_undef ?; subst => /= /eqP h. - by have := type_of_valI v'; rewrite -h. + rewrite read_eE => /(uincl_onI (SvP.MP.union_subset_1 _)) h1 h2. + by have /(_ _ h1) := sem_pexpr_uincl_on _ h2. Qed. -Lemma vmap_uincl_on_set (vm vm': vmap) (x: var) (v v': exec (psem_t (vtype x))) : - eval_uincl v v' → - (vmap_uincl_on (Sv.singleton x) vm.[x <- v] vm'.[x <- v'])%vmap. -Proof. by move => vv' _ /Sv.singleton_spec ->; rewrite !Fv.setP_eq. Qed. - -Lemma set_var_uincl_on vm1 vm1' vm2 x v v' : - value_uincl v v' -> - set_var vm1 x v = ok vm2 -> - exists2 vm2', set_var vm1' x v' = ok vm2' & vmap_uincl_on (Sv.singleton x) vm2 vm2'. +Lemma sem_pexprs_uincl_on' wdb gd es s scs m vm vm' vs1 : + vm <=[read_es_rec s es] vm'-> + sem_pexprs wdb gd (Estate scs m vm) es = ok vs1 -> + exists2 vs2,sem_pexprs wdb gd (Estate scs m vm') es = ok vs2 & + List.Forall2 value_uincl vs1 vs2. Proof. - (move=> Hv; apply: set_varP; rewrite /set_var) => [t | hb]. - + move=> /(pof_val_uincl Hv) [z' [-> ?]] <- /=. - by exists (vm1'.[x <- ok z'])%vmap => //; exact: vmap_uincl_on_set. - by rewrite hb;case: x hb => /= xt xn /eqP -> /(pof_val_undef Hv) [->| [b ->]] /= <-; - (eexists;first reflexivity); apply: vmap_uincl_on_set. + rewrite read_esE => /(uincl_onI (SvP.MP.union_subset_1 _)) h1 h2. + by have /(_ _ h1) := sem_pexprs_uincl_on _ h2. Qed. -Lemma Array_set_uincl n1 n2 - (a1 a1': WArray.array n1) (a2 : WArray.array n2) wz aa i (v:word wz): - @val_uincl (sarr n1) (sarr n2) a1 a2 -> - WArray.set a1 aa i v = ok a1' -> - exists2 a2', WArray.set a2 aa i v = ok a2' & - @val_uincl (sarr n1) (sarr n2) a1' a2'. +Lemma vuincl_exec_opn {sip : SemInstrParams asm_op syscall_state} o vs vs' v : + List.Forall2 value_uincl vs vs' -> exec_sopn o vs = ok v -> + exists2 v', exec_sopn o vs' = ok v' & List.Forall2 value_uincl v v'. Proof. - rewrite /val_uincl /= => hu hs. - by have [?[]]:= WArray.uincl_set hu hs; eauto. + rewrite /exec_sopn /sopn_sem => vs_vs' ho. + exact: (get_instr_desc o).(semu) vs_vs' ho. Qed. -Lemma write_var_uincl_on s1 s2 vm1 v1 v2 x : +Lemma write_var_uincl_on wdb X (x : var_i) v1 v2 s1 s2 vm1 : value_uincl v1 v2 -> - write_var x v1 s1 = ok s2 -> - exists2 vm2 : vmap, - write_var x v2 (with_vm s1 vm1) = ok (with_vm s2 vm2) & - vmap_uincl_on (Sv.singleton x) (evm s2) vm2. + write_var wdb x v1 s1 = ok s2 -> + evm s1 <=[X] vm1 -> + exists2 vm2, + write_var wdb x v2 (with_vm s1 vm1) = ok (with_vm s2 vm2) & + evm s2 <=[Sv.add x X] vm2. Proof. - move=> Hv; rewrite /write_var;t_xrbindP => vm1' Hmv1' <- /=. - by have [vm2' -> ? /=] := set_var_uincl_on vm1 Hv Hmv1'; exists vm2'. + move=> hv; rewrite /write_var;t_xrbindP => vm1' hmv1' <- /= h. + have /(_ (Sv.add x X) vm1) []:= uincl_on_set_var hv _ hmv1'. + + by apply: uincl_onI h; SvD.fsetdec. + by move=> -> ?; eexists; eauto. Qed. -Corollary write_var_uincl s1 s2 vm1 v1 v2 x : - vm_uincl s1.(evm) vm1 -> +Lemma write_var_uincl_on1 wdb s1 s2 vm1 v1 v2 (x : var_i) : + value_uincl v1 v2 -> + write_var wdb x v1 s1 = ok s2 -> + exists2 vm2 : Vm.t, + write_var wdb x v2 (with_vm s1 vm1) = ok (with_vm s2 vm2) & + s2.(evm) <=[Sv.singleton x] vm2. +Proof. by move=> hv /(write_var_uincl_on hv) -/(_ Sv.empty vm1); apply. Qed. + +Corollary write_var_uincl wdb s1 s2 vm1 v1 v2 (x : var_i) : + s1.(evm) <=1 vm1 -> value_uincl v1 v2 -> - write_var x v1 s1 = ok s2 -> - exists2 vm2 : vmap, - write_var x v2 (with_vm s1 vm1) = ok (with_vm s2 vm2) & - vm_uincl s2.(evm) vm2. + write_var wdb x v1 s1 = ok s2 -> + exists2 vm2 : Vm.t, + write_var wdb x v2 (with_vm s1 vm1) = ok (with_vm s2 vm2) & + s2.(evm) <=1 vm2. Proof. - move => Hvm hv /dup[] ok_s2 /(write_var_uincl_on vm1 hv) {hv} [] vm2 ok_vm2 le; exists vm2; first exact: ok_vm2. - apply: (vmap_uincl_on_vm_uincl Hvm le). - - exact: (vrvP_var ok_s2). - exact: (vrvP_var ok_vm2). + move => Hvm hv /dup[] hw1 /(write_var_uincl_on1 vm1 hv) {hv} [] vm2 hw2 le. + exists vm2 => //; apply: (uincl_on_vm_uincl Hvm le); [apply: vrvP_var hw1 | apply: vrvP_var hw2]. Qed. -Lemma write_vars_uincl s1 s2 vm1 vs1 vs2 xs : +Lemma write_vars_uincl wdb s1 s2 vm1 vs1 vs2 xs : vm_uincl (evm s1) vm1 -> List.Forall2 value_uincl vs1 vs2 -> - write_vars xs vs1 s1 = ok s2 -> - exists2 vm2 : vmap, - write_vars xs vs2 (with_vm s1 vm1) = ok (with_vm s2 vm2) & + write_vars wdb xs vs1 s1 = ok s2 -> + exists2 vm2 : Vm.t, + write_vars wdb xs vs2 (with_vm s1 vm1) = ok (with_vm s2 vm2) & vm_uincl (evm s2) vm2. Proof. elim: xs s1 vm1 vs1 vs2 => /= [ | x xs Hrec] s1 vm1 vs1 vs2 Hvm [] //=. + by move=> [] <-;eauto. move=> {vs1 vs2} v1 v2 vs1 vs2 Hv Hvs;apply: rbindP => s1'. - by move=> /(write_var_uincl Hvm Hv) [] vm2 -> Hvm2 /(Hrec _ _ _ _ Hvm2 Hvs). + by move=> /(write_var_uincl Hvm Hv) []vm2 -> Hvm2 /(Hrec _ _ _ _ Hvm2 Hvs). Qed. -Lemma is_sword_subtype t1 t2 : subtype t1 t2 -> is_sword t1 = is_sword t2. -Proof. - by case: t1 => //= [/eqP <-|/eqP <-|?|?] //;case:t2. -Qed. - -Lemma uincl_write_none s2 v1 v2 s s' t: +Lemma uincl_write_none wdb s2 v1 v2 s s' t: value_uincl v1 v2 -> - write_none s t v1 = ok s' -> - write_none s2 t v2 = ok s2. + write_none wdb s t v1 = ok s' -> + write_none wdb s2 t v2 = ok s2. Proof. - move=> Hv /write_noneP [_] H;rewrite /write_none. - case: H. - + by move=> [w1] /(pof_val_uincl Hv) [w2 [->]]. - by move=> [] H1 ?;subst t;move /(pof_val_undef Hv): H1 => [ | [b]] ->. + move=> hu /write_noneP [_ htr hdb];rewrite /write_none. + rewrite (value_uincl_DB hu hdb). + have [|-> //] := vm_truncate_val_uincl _ htr hu. + move=> /eqP /eqP ? hna _ _; subst wdb. + apply: subtype_trans (value_uincl_subtype hu). + by apply: vm_truncate_val_subtype htr. Qed. -Lemma write_uincl_on gd s1 s2 vm1 r v1 v2: - vmap_uincl_on (read_rv r) s1.(evm) vm1 -> +Lemma write_uincl_on wdb gd s1 s2 vm1 r v1 v2: + s1.(evm) <=[read_rv r] vm1 -> value_uincl v1 v2 -> - write_lval gd r v1 s1 = ok s2 -> + write_lval wdb gd r v1 s1 = ok s2 -> exists2 vm2, - write_lval gd r v2 (with_vm s1 vm1) = ok (with_vm s2 vm2) & - vmap_uincl_on (vrv r) s2.(evm) vm2. + write_lval wdb gd r v2 (with_vm s1 vm1) = ok (with_vm s2 vm2) & + s2.(evm) <=[vrv r] vm2. Proof. case: r => [xi ty | x | sz x p | aa sz1 x p | aa sz1 len x p] + Hv; rewrite /= ?read_eE; t_xrbindP=> Hvm1. + move=> H; have [-> _]:= write_noneP H. by rewrite (uincl_write_none _ Hv H); exists vm1. - + exact: write_var_uincl_on. - + move: Hvm1 => /vmap_uincl_on_union[] /sem_pexpr_uincl_on Hvme Hvmx > + + exact: write_var_uincl_on1. + + move: Hvm1 => /uincl_on_union_and[] /sem_pexpr_uincl_on Hvme Hvmx > /get_var_uincl_at -/(_ vm1) /[swap] /to_wordI[? [? [-> /word_uincl_truncate h]]] []. * by apply: Hvmx; SvD.fsetdec. move=> vx2 -> /value_uinclE[? [? [-> /h{h} /= ->]]] > /Hvme{Hvme} [? ->] @@ -1999,7 +1532,7 @@ Proof. subst; move: Hv => /value_uinclE [? [? [-> /word_uincl_truncate h]]] /= /h{h} -> ? /= -> <-. by exists vm1. - + move: Hvm1 => /vmap_uincl_on_union[] /sem_pexpr_uincl_on Hvmp Hvmx. + + move: Hvm1 => /uincl_on_union_and[] /sem_pexpr_uincl_on Hvmp Hvmx. apply: on_arr_varP => n a Htx /get_var_uincl_at - /(_ vm1) []. * by apply: Hvmx; SvD.fsetdec. move=> ? /[swap] /value_uinclE [? -> /WArray.uincl_set hu] ->. @@ -2007,101 +1540,96 @@ Proof. /[swap] /to_intI -> /value_uinclE -> ? /to_wordI [? [? [? ]]]. subst; move: Hv => /value_uinclE[? [? [-> /word_uincl_truncate h]]] /h{h} /= -> ? /hu{hu} /= [? [-> ?]] /write_var_uincl_on. - by apply. - move: Hvm1 => /vmap_uincl_on_union[] /sem_pexpr_uincl_on Hvm1 Hvmx. + by apply => //; rewrite Htx. + move: Hvm1 => /uincl_on_union_and[] /sem_pexpr_uincl_on Hvm1 Hvmx. apply: on_arr_varP => n a Htx /get_var_uincl_at - /(_ vm1) []. + by apply: Hvmx; SvD.fsetdec. move=> ? /[swap] /value_uinclE [? -> /WArray.uincl_set_sub hu] ->. t_xrbindP=> > /Hvm1{Hvm1} [? ->] /[swap] /to_intI -> /value_uinclE -> ? /to_arrI ?. subst; move: Hv => /value_uinclE [? ->] /= h. - rewrite WArray.castK /= => ? /hu -/(_ _ h){hu h} [? -> ?] /= /write_var_uincl_on. - by apply. + by rewrite WArray.castK /= => ? /hu -/(_ _ h){hu h} [? -> ?] /= /write_var_uincl_on; apply => //; rewrite Htx. Qed. -Corollary write_uincl gd s1 s2 vm1 r v1 v2: - vm_uincl s1.(evm) vm1 -> +Corollary write_uincl wdb gd s1 s2 vm1 r v1 v2: + s1.(evm) <=1 vm1 -> value_uincl v1 v2 -> - write_lval gd r v1 s1 = ok s2 -> + write_lval wdb gd r v1 s1 = ok s2 -> exists2 vm2, - write_lval gd r v2 (with_vm s1 vm1) = ok (with_vm s2 vm2) & - vm_uincl s2.(evm) vm2. + write_lval wdb gd r v2 (with_vm s1 vm1) = ok (with_vm s2 vm2) & + s2.(evm) <=1 vm2. Proof. move => hvm hv ok_s2. - case: (write_uincl_on (vm_uincl_vmap_uincl_on hvm) hv ok_s2) => vm2 ok_vm2 hvm2. + case: (write_uincl_on (vm_uincl_uincl_on hvm) hv ok_s2) => vm2 ok_vm2 hvm2. exists vm2; first exact: ok_vm2. - apply: (vmap_uincl_on_vm_uincl hvm hvm2). - - exact: vrvP ok_s2. - exact: vrvP ok_vm2. + apply: (uincl_on_vm_uincl hvm hvm2);[ apply: vrvP ok_s2 | apply: vrvP ok_vm2]. Qed. -Lemma writes_uincl_on gd s1 s2 vm1 r v1 v2: - vmap_uincl_on (read_rvs r) s1.(evm) vm1 -> +Lemma writes_uincl_on wdb gd s1 s2 vm1 r v1 v2: + s1.(evm) <=[read_rvs r] vm1 -> List.Forall2 value_uincl v1 v2 -> - write_lvals gd s1 r v1 = ok s2 -> + write_lvals wdb gd s1 r v1 = ok s2 -> exists2 vm2, - write_lvals gd (with_vm s1 vm1) r v2 = ok (with_vm s2 vm2) & - vmap_uincl_on (vrvs r) s2.(evm) vm2. + write_lvals wdb gd (with_vm s1 vm1) r v2 = ok (with_vm s2 vm2) & + s2.(evm) <=[vrvs r] vm2. Proof. elim: r v1 v2 s1 s2 vm1 => [ | r rs Hrec] ?? s1 s2 vm1 Hvm1 /= [] //=. - + by case => <-; exists vm1. - move: Hvm1; rewrite read_rvs_cons => /vmap_uincl_on_union[] hr hrs. + + by move=> [<-]; exists vm1. + move: Hvm1; rewrite read_rvs_cons => /uincl_on_union_and[] hr hrs. move=> v1 v2 vs1 vs2 Hv Hforall. apply: rbindP => z ok_z ok_s2. have [ vm2 ok_vm2 Hvm2 ] := write_uincl_on hr Hv ok_z. - have h : vmap_uincl_on (read_rvs rs) (evm z) vm2. + have h : evm z <=[read_rvs rs] vm2. + move => x hx. case: (Sv_memP x (vrv r)); first exact: Hvm2. move => hxr; rewrite -(vrvP ok_z hxr) -(vrvP ok_vm2 hxr). exact: hrs. have [ vm3 ok_vm3 h3 ] := Hrec _ _ _ _ vm2 h Hforall ok_s2. exists vm3; first by rewrite ok_vm2. - rewrite vrvs_cons vmap_uincl_on_union; split; last exact: h3. + rewrite vrvs_cons uincl_on_union_and; split; last exact: h3. move => x hx. case: (Sv_memP x (vrvs rs)); first exact: h3. move => hxrs; rewrite -(vrvsP ok_vm3 hxrs) -(vrvsP ok_s2 hxrs). exact: Hvm2. Qed. -Corollary writes_uincl gd s1 s2 vm1 r v1 v2: - vm_uincl s1.(evm) vm1 -> +Corollary writes_uincl wdb gd s1 s2 vm1 r v1 v2: + s1.(evm) <=1 vm1 -> List.Forall2 value_uincl v1 v2 -> - write_lvals gd s1 r v1 = ok s2 -> + write_lvals wdb gd s1 r v1 = ok s2 -> exists2 vm2, - write_lvals gd (with_vm s1 vm1) r v2 = ok (with_vm s2 vm2) & - vm_uincl s2.(evm) vm2. + write_lvals wdb gd (with_vm s1 vm1) r v2 = ok (with_vm s2 vm2) & + s2.(evm) <=1 vm2. Proof. move => hvm hv ok_s2. - case: (writes_uincl_on (vm_uincl_vmap_uincl_on hvm) hv ok_s2) => vm2 ok_vm2 hvm2. + case: (writes_uincl_on (vm_uincl_uincl_on hvm) hv ok_s2) => vm2 ok_vm2 hvm2. exists vm2; first exact: ok_vm2. - apply: (vmap_uincl_on_vm_uincl hvm hvm2). - - exact: vrvsP ok_s2. - exact: vrvsP ok_vm2. + apply: (uincl_on_vm_uincl hvm hvm2); [apply: vrvsP ok_s2 | apply: vrvsP ok_vm2]. Qed. -Lemma write_vars_lvals gd xs vs s1: - write_vars xs vs s1 = write_lvals gd s1 [seq Lvar i | i <- xs] vs. +Lemma write_vars_lvals wdb gd xs vs s1: + write_vars wdb xs vs s1 = write_lvals wdb gd s1 [seq Lvar i | i <- xs] vs. Proof. rewrite /write_vars /write_lvals. elim: xs vs s1 => [ | x xs Hrec] [ | v vs] //= s1. by case: write_var => //=. Qed. -Lemma sem_pexprs_get_var gd s xs : - sem_pexprs gd s [seq Pvar (mk_lvar i) | i <- xs] = - mapM (fun x : var_i => get_var (evm s) x) xs. +Lemma sem_pexprs_get_var wdb gd s xs : + sem_pexprs wdb gd s [seq Pvar (mk_lvar i) | i <- xs] = + mapM (fun x : var_i => get_var wdb (evm s) x) xs. Proof. rewrite /sem_pexprs;elim: xs=> //= x xs Hrec. rewrite /get_gvar /=. by case: get_var => //= v;rewrite Hrec. Qed. -Lemma get_vars_uincl_on dom (xs: seq var_i) vm1 vm2 vs1: - vmap_uincl_on dom vm1 vm2 -> +Lemma get_vars_uincl_on wdb dom (xs: seq var_i) vm1 vm2 vs1: + vm1 <=[dom] vm2 -> (∀ x, List.In x xs → Sv.mem x dom) → - mapM (fun x => get_var vm1 (v_var x)) xs = ok vs1 -> + mapM (fun x => get_var wdb vm1 (v_var x)) xs = ok vs1 -> exists2 vs2, - mapM (fun x => get_var vm2 (v_var x)) xs = ok vs2 & List.Forall2 value_uincl vs1 vs2. + mapM (fun x => get_var wdb vm2 (v_var x)) xs = ok vs2 & List.Forall2 value_uincl vs1 vs2. Proof. move => hvm; elim: xs vs1 => [ | x xs Hrec] /= ? hdom. + by move=> [<-]; exists [::]. @@ -2114,111 +1642,46 @@ Proof. by constructor. Qed. -Lemma get_vars_uincl (xs:seq var_i) vm1 vm2 vs1: - vm_uincl vm1 vm2 -> - mapM (fun x => get_var vm1 (v_var x)) xs = ok vs1 -> +Lemma get_vars_uincl wdb (xs:seq var_i) vm1 vm2 vs1: + vm1 <=1 vm2 -> + mapM (fun x => get_var wdb vm1 (v_var x)) xs = ok vs1 -> exists2 vs2, - mapM (fun x => get_var vm2 (v_var x)) xs = ok vs2 & List.Forall2 value_uincl vs1 vs2. + mapM (fun x => get_var wdb vm2 (v_var x)) xs = ok vs2 & List.Forall2 value_uincl vs1 vs2. Proof. - move => hvm; apply: (@get_vars_uincl_on (sv_of_list v_var xs)). - + exact: vm_uincl_vmap_uincl_on hvm. + move => hvm; apply: (@get_vars_uincl_on _ (sv_of_list v_var xs)). + + exact: vm_uincl_uincl_on hvm. move => /= y hy; rewrite sv_of_listE; apply/in_map. by exists y. Qed. -(* can be merged with sem_pexpr_uincl_on *) -Lemma sem_pexpr_uincl_on' gd s vm' vm scs m e v1 : - vm <=[read_e_rec s e] vm' -> - sem_pexpr gd {| escs := scs; emem := m; evm := vm |} e = ok v1 -> - exists2 v2 : value, - sem_pexpr gd {| escs := scs; emem := m; evm := vm' |} e = ok v2 & value_uincl v1 v2. -Proof. - move=> hsub. - pose vm1 : vmap := - Fv.empty (fun (x:var) => if Sv.mem x (read_e_rec s e) then vm.[x] else vm'.[x]). - rewrite (@read_e_eq_on _ s vm1) /with_vm /=; last first. - + by move=> ? /Sv_memP; rewrite /vm1 Fv.get0 => ->. - have hle: vm_uincl vm1 vm'. - + by move=> ?;rewrite /vm1 Fv.get0;case:ifP => // /Sv_memP -/hsub. - by apply: sem_pexpr_uincl. -Qed. - -(* can be merged with sem_pexprs_uincl_on *) -Lemma sem_pexprs_uincl_on' gd es s scs m vm vm' vs1 : - vm <=[read_es_rec s es] vm'-> - sem_pexprs gd (Estate scs m vm) es = ok vs1 -> - exists2 vs2,sem_pexprs gd (Estate scs m vm') es = ok vs2 & - List.Forall2 value_uincl vs1 vs2. -Proof. - move=> hsub. - pose vm1 : vmap := - Fv.empty (fun (x:var) => if Sv.mem x (read_es_rec s es) then vm.[x] else vm'.[x]). - rewrite (read_es_eq_on _ (s := s) (vm' := vm1)) /with_vm /=; last first. - + by move=> ? /Sv_memP; rewrite /vm1 Fv.get0 => ->. - have hle: vm_uincl vm1 vm'. - + by move=> ?;rewrite /vm1 Fv.get0;case:ifP => // /Sv_memP -/hsub. - by apply: sem_pexprs_uincl. -Qed. - -(* can be merged with write_var_uincl_on *) -Lemma write_var_uincl_on' X x v1 v2 s1 s2 vm1 : - value_uincl v1 v2 -> - write_var x v1 s1 = ok s2 -> - evm s1 <=[X] vm1 -> - exists2 vm2 : vmap,evm s2 <=[Sv.add x X] vm2 & - write_var x v2 (with_vm s1 vm1) = ok (with_vm s2 vm2). -Proof. - move=> hu hw hsub;pose vm1' : vmap := - Fv.empty (fun (x:var) => if Sv.mem x X then (evm s1).[x] else vm1.[x]). - have heq_on : evm s1 =[X] vm1'. - + by move=> ? /Sv_memP;rewrite /vm1' Fv.get0 /= => ->. - have [vm2' [heq_on' ]]:= write_var_eq_on hw heq_on. - have: vm_uincl vm1' vm1. - + by move=> ?;rewrite /vm1' Fv.get0 /=;case:ifP => // /Sv_memP -/hsub. - move=> H /(write_var_uincl _ hu) -/(_ _ H) /= [vm2 -> hvmu]; eexists; last reflexivity. - by move=> ? hin;rewrite heq_on'. -Qed. - -Lemma write_lval_uincl_on gd X x v1 v2 s1 s2 vm1 : +Lemma write_lval_uincl_on wdb gd X x v1 v2 s1 s2 vm1 : Sv.Subset (read_rv x) X -> value_uincl v1 v2 -> - write_lval gd x v1 s1 = ok s2 -> + write_lval wdb gd x v1 s1 = ok s2 -> evm s1 <=[X] vm1 -> - exists2 vm2 : vmap,evm s2 <=[Sv.union (vrv x) X] vm2 & - write_lval gd x v2 (with_vm s1 vm1) = ok (with_vm s2 vm2). + exists2 vm2 : Vm.t,evm s2 <=[Sv.union (vrv x) X] vm2 & + write_lval wdb gd x v2 (with_vm s1 vm1) = ok (with_vm s2 vm2). Proof. - move=> hsubset hu hw hsub;pose vm1' : vmap := - Fv.empty (fun (x:var) => if Sv.mem x X then (evm s1).[x] else vm1.[x]). - have heq_on : evm s1 =[X] vm1'. - + by move=> ? /Sv_memP;rewrite /vm1' Fv.get0 /= => ->. - have [vm2' [heq_on' ]]:= write_lval_eq_on hsubset hw heq_on. - have: vm_uincl vm1' vm1. - + by move=> ?;rewrite /vm1' Fv.get0 /=;case:ifP => // /Sv_memP -/hsub. - move=> H /(write_uincl _ hu) -/(_ _ H) /= [vm2 -> hvmu];eexists; last reflexivity. - by move=> ? hin;rewrite heq_on'. + move=> hX hvu hw hu. + have [vm2 hw2 hu2] := write_uincl_on (uincl_onI hX hu) hvu hw. + exists vm2 => //; apply: (uincl_on_union hu hu2); [ apply: vrvP hw | apply: vrvP hw2]. Qed. -Lemma write_lvals_uincl_on gd X x v1 v2 s1 s2 vm1 : +Lemma write_lvals_uincl_on wdb gd X x v1 v2 s1 s2 vm1 : Sv.Subset (read_rvs x) X -> List.Forall2 value_uincl v1 v2 -> - write_lvals gd s1 x v1 = ok s2 -> + write_lvals wdb gd s1 x v1 = ok s2 -> evm s1 <=[X] vm1 -> - exists2 vm2 : vmap,evm s2 <=[Sv.union (vrvs x) X] vm2 & - write_lvals gd (with_vm s1 vm1) x v2 = ok (with_vm s2 vm2). + exists2 vm2 : Vm.t,evm s2 <=[Sv.union (vrvs x) X] vm2 & + write_lvals wdb gd (with_vm s1 vm1) x v2 = ok (with_vm s2 vm2). Proof. - move=> hsubset hu hw hsub;pose vm1' : vmap := - Fv.empty (fun (x:var) => if Sv.mem x X then (evm s1).[x] else vm1.[x]). - have heq_on : evm s1 =[X] vm1'. - + by move=> ? /Sv_memP;rewrite /vm1' Fv.get0 /= => ->. - have [vm2' [heq_on' ]]:= write_lvals_eq_on hsubset hw heq_on. - have: vm_uincl vm1' vm1. - + by move=> ?;rewrite /vm1' Fv.get0 /=;case:ifP => // /Sv_memP -/hsub. - move=> H /(writes_uincl _ hu) -/(_ _ H) /= [vm2 -> hvmu]; eexists; last reflexivity. - by move=> ? hin;rewrite heq_on'. + move=> hX hvu hw hu. + have [vm2 hw2 hu2] := writes_uincl_on (uincl_onI hX hu) hvu hw. + exists vm2 => //; apply: (uincl_on_union hu hu2); [ apply: vrvsP hw | apply: vrvsP hw2]. Qed. Lemma write_lval_undef gd l v s1 s2 sz : - write_lval gd l v s1 = ok s2 -> + write_lval true gd l v s1 = ok s2 -> type_of_val v = sword sz -> exists w: word sz, v = Vword w. Proof. @@ -2228,67 +1691,245 @@ Proof. + move=> sz' w [<-] _; by exists w. case => //= ?? [<-] /=. case: l => /=. - + by move => _ [] //; rewrite /write_none /= => sz'; case: eqP. - + by case => - [] [] // sz' vn vi; rewrite /write_var /set_var /=; case: eqP. - + by move => sz' v e; t_xrbindP; case: ifP. + + by move => _ ? /write_noneP []. + + by rewrite /write_var; t_xrbindP => > /set_varP []. + + by t_xrbindP. + by move => aa ws [] [vt vn] /= _ e; apply: on_arr_varP => n t hty /= ?; t_xrbindP. by move => aa ws len [] [vt vn] /= _ e; apply: on_arr_varP => n t hty /= ?; t_xrbindP. Qed. -(* ---------------------------------------------------------------- *) -(* value inclusion on vmap except on X *) +(* MOVE THIS *) +Section Expr. + +Context (wdb : bool) (gd : glob_decls) (s : estate). + +Let P e : Prop := + forall v, sem_pexpr true gd s e = ok v -> sem_pexpr wdb gd s e = ok v. + +Let Q es : Prop := + forall vs, sem_pexprs true gd s es = ok vs -> sem_pexprs wdb gd s es = ok vs. + +Lemma get_var_wdb vm x v : get_var true vm x = ok v -> get_var wdb vm x = ok v. +Proof. by move=> /get_varP [-> h1 h2]; rewrite /get_var; case: wdb => //; rewrite h1. Qed. -Definition vmap_uincl_ex (dom: Sv.t) : relation vmap := - λ vm1 vm2, - ∀ x : var, ~Sv.In x dom → (eval_uincl vm1.[x] vm2.[x])%vmap. +Lemma get_gvar_wdb vm x v : get_gvar true gd vm x = ok v -> get_gvar wdb gd vm x = ok v. +Proof. rewrite /get_gvar; case: ifP => // _; apply get_var_wdb. Qed. -#[ global ] Arguments vmap_uincl_ex _ _%vmap _%vmap. +Lemma sem_pexpr_wdb_and : (forall e, P e) /\ (forall es, Q es). +Proof. + apply: pexprs_ind_pair; subst P Q; split => //=. + + by move=> e he es hes vs; t_xrbindP => ? /he -> ? /hes -> <-. + + by move=> x v; apply get_gvar_wdb. + + move=> aa ws x e he v; apply on_arr_gvarP; t_xrbindP; rewrite /on_arr_var. + by move=> len a ha /get_gvar_wdb -> ?? /he -> /= -> ? /= -> <-. + + move=> aa ws len x e he v; apply on_arr_gvarP; t_xrbindP; rewrite /on_arr_var. + by move=> ??? /get_gvar_wdb -> ?? /he -> /= -> ? /= -> <-. + + by t_xrbindP => > he > /get_var_wdb -> /= -> > /he -> /= -> /= > -> <-. + + by t_xrbindP => > he > /he -> /= ->. + + by t_xrbindP => > he1 > he2 > /he1 -> > /he2 -> /= ->. + + by t_xrbindP => > hes > /hes; rewrite -/(sem_pexprs _ _ _) => -> /= <-. + by t_xrbindP => > he > he1 > he2 > /he -> /= -> > /he1 -> /= -> > /he2 -> /= -> <-. +Qed. + +Lemma sem_pexpr_wdb e : P e. +Proof. by case: sem_pexpr_wdb_and. Qed. + +Lemma sem_pexprs_wdb e : Q e. +Proof. by case: sem_pexpr_wdb_and. Qed. -Notation "vm1 '<=[\' s ']' vm2" := (vmap_uincl_ex s vm1 vm2) (at level 70, vm2 at next level, - format "'[hv ' vm1 <=[\ s ] '/' vm2 ']'"). +Lemma sem_pexpr_ext_eq e vm : + evm s =1 vm -> + sem_pexpr wdb gd s e = sem_pexpr wdb gd (with_vm s vm) e. +Proof. by move=> heq; apply/read_e_eq_on_empty/vm_eq_eq_on. Qed. -Lemma vmap_uincl_exT vm2 X vm1 vm3 : - vm1 <=[\X] vm2 -> vm2 <=[\X] vm3 -> vm1 <=[\X] vm3. -Proof. move=> H1 H2 ? hnin;apply: eval_uincl_trans (H1 _ hnin) (H2 _ hnin). Qed. +Lemma sem_pexprs_ext_eq es vm : + evm s =1 vm -> + sem_pexprs wdb gd s es = sem_pexprs wdb gd (with_vm s vm) es. +Proof. by move=> heq; apply/read_es_eq_on_empty/vm_eq_eq_on. Qed. -Lemma vmap_uincl_exI s1 s2 vm1 vm2 : Sv.Subset s2 s1 -> vm1 <=[\s2] vm2 -> vm1 <=[\s1] vm2. -Proof. move=> Hs Heq x Hin;apply Heq;SvD.fsetdec. Qed. +Lemma write_lvar_ext_eq x v s1 s2 vm1 : + evm s1 =1 vm1 -> + write_lval wdb gd x v s1 = ok s2 -> + exists2 vm2, evm s2 =1 vm2 & write_lval wdb gd x v (with_vm s1 vm1) = ok (with_vm s2 vm2). +Proof. + move=> he hw. + have hsub : Sv.Subset (read_rv x) (read_rv x) by SvD.fsetdec. + have heq : evm s1 =[read_rv x] vm1 by move=> ??;rewrite he. + have [vm2 hw2 heq2]:= write_lval_eq_on hsub hw heq. + exists vm2 => //. + apply: (eq_on_eq_vm (d:=vrv x) he). + + by apply: eq_onI heq2; SvD.fsetdec. + + by apply: vrvP hw. + by apply: vrvP hw2. +Qed. + +Lemma write_lvars_ext_eq xs vs s1 s2 vm1 : + evm s1 =1 vm1 -> + write_lvals wdb gd s1 xs vs = ok s2 -> + exists2 vm2, evm s2 =1 vm2 & write_lvals wdb gd (with_vm s1 vm1) xs vs = ok (with_vm s2 vm2). +Proof. + move=> he hw. + have hsub : Sv.Subset (read_rvs xs) (read_rvs xs) by SvD.fsetdec. + have heq : evm s1 =[read_rvs xs] vm1 by move=> ??;rewrite he. + have [vm2 hw2 heq2]:= write_lvals_eq_on hsub hw heq. + exists vm2 => //. + apply: (eq_on_eq_vm (d:=vrvs xs) he). + + by apply: eq_onI heq2; SvD.fsetdec. + + by apply: vrvsP hw. + by apply: vrvsP hw2. +Qed. -Lemma vmap_uincl_ex_refl X vm : vm <=[\X] vm. -Proof. done. Qed. -Hint Resolve vmap_uincl_ex_refl : core. +End Expr. -Lemma vmap_eq_except_uincl_ex X vm1 vm2 : - vm1 = vm2 [\X] -> vm1 <=[\X] vm2. -Proof. by move=> H ? /H ->. Qed. -Lemma vm_uincl_vmap_uincl_ex dom vm1 vm2 : - vm_uincl vm1 vm2 → - vm1 <=[\dom] vm2. -Proof. by move => h x _; exact: h. Qed. +Section Sem_eqv. +Context + {dc:DirectCall} + {sip : SemInstrParams asm_op syscall_state} + {T} + {pT : progT T} + {sCP : semCallParams} + (p:prog) (ev : extra_val_t). -Global Instance vmap_uincl_ex_impl : Proper (Sv.Subset ==> eq ==> eq ==> Basics.impl) - vmap_uincl_ex. -Proof. by move=> s1 s2 H vm1 ? <- vm2 ? <-;apply: vmap_uincl_exI. Qed. +Let Pc s1 c s2 := + forall vm1 X, + Sv.Subset (read_c c) X -> + evm s1 =[X] vm1 -> + exists2 vm2, sem p ev (with_vm s1 vm1) c (with_vm s2 vm2) & evm s2 =[X] vm2. + +Let Pi s1 (i:instr) s2 := + forall vm1 X, + Sv.Subset (read_I i) X -> + evm s1 =[X] vm1 -> + exists2 vm2, sem_I p ev (with_vm s1 vm1) i (with_vm s2 vm2) & evm s2 =[X] vm2. + +Let Pi_r s1 (i:instr_r) s2 := + forall vm1 X, + Sv.Subset (read_i i) X -> + evm s1 =[X] vm1 -> + exists2 vm2, sem_i p ev (with_vm s1 vm1) i (with_vm s2 vm2) & evm s2 =[X] vm2. -Global Instance vmap_uincl_ex_m : Proper (Sv.Equal ==> eq ==> eq ==> iff) vmap_uincl_ex. -Proof. by move=> s1 s2 Heq vm1 ? <- vm2 ? <-;split;apply: vmap_uincl_exI;rewrite Heq. Qed. +Let Pfor (i:var_i) zs s1 c s2 := + forall vm1 X, + Sv.Subset (read_c c) X -> + evm s1 =[X] vm1 -> + exists2 vm2, sem_for p ev i zs (with_vm s1 vm1) c (with_vm s2 vm2) & evm s2 =[X] vm2. -Instance vmap_uincl_ex_trans dom : Transitive (vmap_uincl_ex dom). -Proof. move => x y z xy yz r hr; apply: (eval_uincl_trans (xy _ hr)); exact: yz. Qed. +Let Pfun (scs:syscall_state) (m:mem) (fn:funname) (args: values) (scs':syscall_state) (m':mem) (res:values) := true. -Lemma vmap_uincl_ex_empty vm1 vm2 : - vm1 <=[\ Sv.empty ] vm2 ↔ vm_uincl vm1 vm2. +Lemma read_cP X s1 c s2 vm1 : + sem p ev s1 c s2 -> + Sv.Subset (read_c c) X -> + evm s1 =[X] vm1 -> + exists2 vm2, sem p ev (with_vm s1 vm1) c (with_vm s2 vm2) & evm s2 =[X] vm2. +Proof. + move=> hsem;move: hsem vm1 X. + apply : (sem_Ind (Pc := Pc) (Pi := Pi) (Pi_r := Pi_r) (Pfor := Pfor) (Pfun := Pfun)) => {s1 c s2}. + + by move=> s vm1 X hsub heq; exists vm1 => //;constructor. + + move=> s1 s2 s3 i c _ ihi _ ihc vm1 X; rewrite read_c_cons => hsub heq1. + have [|vm2 hi heq2] := ihi vm1 X _ heq1; first by SvD.fsetdec. + have [|vm3 hc heq3] := ihc vm2 X _ heq2; first by SvD.fsetdec. + by exists vm3 => //; econstructor; eauto. + + move=> ii i s1 s2 _ ih vm1 X; rewrite read_Ii => hsub heq1. + by case: (ih vm1 X hsub heq1) => vm2 ??;exists vm2. + + move=> s1 s2 x t ty e v v' he htr hw vm1 X. + rewrite read_i_assgn => hsub heq1. + have [|vm2 ? heq2] := write_lval_eq_on _ hw heq1; first by SvD.fsetdec. + exists vm2. + + econstructor; eauto. + rewrite -read_e_eq_on_empty //. + by rewrite read_eE => z hz; apply heq1; SvD.fsetdec. + by move=> z hz;apply heq2; SvD.fsetdec. + + move=> s1 s2 t o xs es. + rewrite /sem_sopn; t_xrbindP => vargs vres hes hex hw vm1 X. + rewrite read_i_opn => hsub heq1. + have [|vm2 hw2 heq2] := write_lvals_eq_on _ hw heq1; first by SvD.fsetdec. + exists vm2; last by apply: eq_onI heq2; SvD.fsetdec. + econstructor; eauto. + rewrite /sem_sopn -(read_es_eq_on _ _ (s := X)) //; last first. + + by move=> z;rewrite read_esE => hz;apply heq1; SvD.fsetdec. + by rewrite hes /= hex /= hw2. + + move=> s1 scs m s2 o xs es ves vs hes ho hw vm1 X. + rewrite read_i_syscall => hsub heq1. + have [|vm2 hw2 heq2] := write_lvals_eq_on _ hw heq1; first by SvD.fsetdec. + exists vm2 => //; last by apply: eq_onI heq2; SvD.fsetdec. + econstructor; eauto. + rewrite -(read_es_eq_on _ _ (s := X)) //. + by move=> z;rewrite read_esE => hz;apply heq1; SvD.fsetdec. + + move=> s1 s2 e c1 c2 he _ ih vm1 X. + rewrite read_i_if => hsub heq1. + have [|vm2 hs2 heq2] := ih vm1 X _ heq1; first SvD.fsetdec. + exists vm2 => //; apply Eif_true => //. + rewrite -read_e_eq_on_empty //. + by rewrite read_eE; apply: eq_onI heq1; SvD.fsetdec. + + move=> s1 s2 e c1 c2 he _ ih vm1 X. + rewrite read_i_if => hsub heq1. + have [|vm2 hs2 heq2]:= ih vm1 X _ heq1; first SvD.fsetdec. + exists vm2 => //; apply Eif_false => //. + rewrite -read_e_eq_on_empty //. + by rewrite read_eE; apply: eq_onI heq1; SvD.fsetdec. + + move=> s1 s2 s3 s4 a c1 e c2 _ ih1 he _ ih2 _ ihw vm1 X. + rewrite read_i_while => hsub heq1. + have [|vm2 hs1 heq2] := ih1 vm1 X _ heq1; first SvD.fsetdec. + have [|vm3 hs2 heq3] := ih2 vm2 X _ heq2; first SvD.fsetdec. + have [|vm4 hs3 heq4] := ihw vm3 X _ heq3; first by rewrite read_i_while. + exists vm4 => //; apply: Ewhile_true; eauto. + rewrite -read_e_eq_on_empty //. + by rewrite read_eE; apply: eq_onI heq2; SvD.fsetdec. + + move=> s1 s2 a c1 e c2 _ ih1 he vm1 X. + rewrite read_i_while => hsub heq1. + have [|vm2 hs1 heq2]:= ih1 vm1 X _ heq1; first SvD.fsetdec. + exists vm2 => //; apply: Ewhile_false; eauto. + rewrite -read_e_eq_on_empty //. + by rewrite read_eE; apply: eq_onI heq2; SvD.fsetdec. + + move=> s1 s2 i d lo hi c vlo vhi hlo hhi _ ih vm1 X. + rewrite read_i_for => hsub heq1. + have [|vm2 ? heq2]:= ih vm1 X _ heq1; first by SvD.fsetdec. + exists vm2 => //. + by econstructor; + eauto; + rewrite -read_e_eq_on_empty // read_eE; + apply: eq_onI heq1; SvD.fsetdec. + + by move=> s1 i c vm1 X hsub heq1; exists vm1 => //;constructor. + + move=> s1 s2 s3 s4 i z zs c hwi _ ihc _ ihf vm1 X hsub heq1. + have [vm2 hw2 heq2] := write_var_eq_on hwi heq1. + have [|vm3 ? heq3] := ihc vm2 X hsub; first by apply: eq_onI heq2; SvD.fsetdec. + have [vm4 ? heq4] := ihf vm3 X hsub heq3; exists vm4 => //. + by econstructor; eauto. + + move=> s1 scs2 m2 s2 ii xs fn args vargs vs hargs hcall _ hw vm1 X. + rewrite read_i_call => hsub heq1. + case: (write_lvals_eq_on _ hw heq1); first by SvD.fsetdec. + move=> vm2 hw2 heq2; exists vm2; last by apply: eq_onI heq2; SvD.fsetdec. + econstructor; eauto. + by rewrite -(read_es_eq_on _ _ (s := X)) // read_esE; + apply: eq_onI heq1; + SvD.fsetdec. + done. +Qed. + +Lemma sem_vm_eq s1 c s2 vm1: + sem p ev s1 c s2 -> + evm s1 =1 vm1 -> + exists2 vm2, sem p ev (with_vm s1 vm1) c (with_vm s2 vm2) & evm s2 =1 vm2. Proof. - split; last exact: vm_uincl_vmap_uincl_ex. - move => h x; apply/h. - SvD.fsetdec. + move=> hsem heq1. + case: (read_cP (vm1 := vm1) (X:= Sv.union (read_c c) (write_c c)) hsem). + + by SvD.fsetdec. + + by move=> x hx;apply heq1. + move=> vm2 hsem2 heq2; exists vm2 => //. + move=> x; case: (Sv_memP x (write_c c)) => hx. + + by apply heq2; SvD.fsetdec. + rewrite -(writeP hsem) // heq1 //. + by have := writeP hsem2; rewrite !evm_with_vm => ->. Qed. +End Sem_eqv. + (* ---------------------------------------------------------------- *) Section UNDEFINCL. Context + {dc:DirectCall} {sip : SemInstrParams asm_op syscall_state} {T} {pT : progT T} @@ -2300,31 +1941,31 @@ Notation gd:= (p_globs p). Let Pc s1 c s2 := forall vm1 , - vm_uincl (evm s1) vm1 -> + evm s1 <=1 vm1 -> exists vm2, sem p ev (with_vm s1 vm1) c (with_vm s2 vm2) /\ - vm_uincl (evm s2) vm2. + evm s2 <=1 vm2. Let Pi_r s1 i s2 := forall vm1, - vm_uincl (evm s1) vm1 -> + evm s1 <=1 vm1 -> exists vm2, sem_i p ev (with_vm s1 vm1) i (with_vm s2 vm2) /\ - vm_uincl (evm s2) vm2. + evm s2 <=1 vm2. Let Pi s1 i s2 := forall vm1, - vm_uincl (evm s1) vm1 -> + evm s1 <=1 vm1 -> exists vm2, sem_I p ev (with_vm s1 vm1) i (with_vm s2 vm2) /\ - vm_uincl (evm s2) vm2. + evm s2 <=1 vm2. Let Pfor (i:var_i) zs s1 c s2 := forall vm1, - vm_uincl (evm s1) vm1 -> + evm s1 <=1 vm1 -> exists vm2, sem_for p ev i zs (with_vm s1 vm1) c (with_vm s2 vm2) /\ - vm_uincl (evm s2) vm2. + evm s2 <=1 vm2. Let Pfun scs1 m1 fd vargs scs2 m2 vres := forall vargs', @@ -2442,15 +2083,49 @@ Proof. move=> /all2P H1 H2;apply /all2P;apply: Forall2_trans H1 H2;apply check_ty_val_uincl. Qed. +Lemma mapM2_id tyin vargs vargs' : + mapM2 ErrType (λ (_ : stype) (v : value), ok v) tyin vargs = ok vargs' -> + vargs = vargs'. +Proof. + elim: tyin vargs vargs' => /= [ | ty tyin hrec] [ | v vs] // >. + + by move=> []. + by t_xrbindP => > /hrec -> <-. +Qed. + +Lemma dc_truncate_value_uincl t v1 v2 : dc_truncate_val t v1 = ok v2 → value_uincl v2 v1. +Proof. + rewrite /dc_truncate_val; case: ifP => [_ [<-] // | _]. + apply truncate_value_uincl. +Qed. + +Lemma mapM2_dc_truncate_value_uincl tyin vargs vargs' : + mapM2 ErrType dc_truncate_val tyin vargs = ok vargs' → List.Forall2 value_uincl vargs' vargs. +Proof. + rewrite /dc_truncate_val; case: direct_call; last by apply mapM2_truncate_value_uincl. + by move=> /mapM2_id ->; apply List_Forall2_refl. +Qed. + +Lemma mapM2_dc_truncate_val tys vs1' vs1 vs2' : + mapM2 ErrType dc_truncate_val tys vs1' = ok vs1 → + List.Forall2 value_uincl vs1' vs2' → + exists2 vs2 : seq value, + mapM2 ErrType dc_truncate_val tys vs2' = ok vs2 & List.Forall2 value_uincl vs1 vs2. +Proof. + rewrite /dc_truncate_val; case: direct_call; last by apply mapM2_truncate_val. + move=> h1 h2; elim: h2 tys vs1 h1 => {vs1' vs2'} [ | v1 v2 vs1' vs2' hu hus hrec] [] //=. + + by move=> ? [<-]; exists [::]. + t_xrbindP => _ tys ?? /hrec [vs2 -> hall] <- /=; eexists; eauto. +Qed. + Local Lemma Hproc : sem_Ind_proc p ev Pc Pfun. Proof. move=> scs1 m1 scs2 m2 fn fd vargs vargs' s0 s1 s2 vres vres' Hget Hca hi Hargs Hsem Hrec Hmap Hcr hscs Hfi vargs1' Uargs. - have [vargs2' hm2 Uargs']:= mapM2_truncate_val Hca Uargs. + have [vargs2' hm2 Uargs']:= mapM2_dc_truncate_val Hca Uargs. have := write_vars_uincl (vm_uincl_refl _) Uargs' Hargs. rewrite with_vm_same => -[vm1 Hargs' Hvm1]. have [vm2' /= [] Hsem' Uvm2]:= Hrec _ Hvm1. have [vs2 Hvs2 Hsub] := get_vars_uincl Uvm2 Hmap. - have [vres2' hmr2 Ures']:= mapM2_truncate_val Hcr Hsub. + have [vres2' hmr2 Ures']:= mapM2_dc_truncate_val Hcr Hsub. by exists vres2';split=>//;econstructor;eauto. Qed. @@ -2574,24 +2249,24 @@ Qed. End UNDEFINCL. -Lemma eq_expr_recP gd s (es es': pexprs) : +Lemma eq_expr_recP wdb gd s (es es': pexprs) : (∀ e : pexpr, List.In e es → - ∀ e' : pexpr, eq_expr e e' → sem_pexpr gd s e = sem_pexpr gd s e') → + ∀ e' : pexpr, eq_expr e e' → sem_pexpr wdb gd s e = sem_pexpr wdb gd s e') → all2 eq_expr es es' → - sem_pexprs gd s es = sem_pexprs gd s es'. + sem_pexprs wdb gd s es = sem_pexprs wdb gd s es'. Proof. elim: es es'; first by case. move => e es ih [] //= e' es' rec /andP [] he hes. rewrite (rec e _ e' he); last by left. - case: (sem_pexpr _ _ e') => //= v. + case: (sem_pexpr _ _ _ e') => //= v. rewrite (ih es') // => q hq q' hq'. by apply: rec => //; right. Qed. -Lemma eq_gvarP gd vm x x' : eq_gvar x x' → get_gvar gd vm x = get_gvar gd vm x'. +Lemma eq_gvarP wdb gd vm x x' : eq_gvar x x' → get_gvar wdb gd vm x = get_gvar wdb gd vm x'. Proof. by rewrite /eq_gvar /get_gvar /is_lvar => /andP [] /eqP -> /eqP ->. Qed. -Lemma eq_exprP gd s e1 e2 : eq_expr e1 e2 -> sem_pexpr gd s e1 = sem_pexpr gd s e2. +Lemma eq_exprP wdb gd s e1 e2 : eq_expr e1 e2 -> sem_pexpr wdb gd s e1 = sem_pexpr wdb gd s e2. Proof. elim: e1 e2=> [z | b | n | x | aa sz x e He | aa sz len x e He | sz x e He | o e He | o e1 He1 e2 He2 | o es Hes | t e He e1 He1 e2 He2] [z' | b' | n' | x' | aa' sz' x' e' | aa' sz' len' x' e' | sz' x' e' | o' e' | o' e1' e2' | o' es' | t' e' e1' e2'] //=. @@ -2602,84 +2277,29 @@ Proof. + by case/andP => /andP [] /eqP -> /eqP -> /He ->. + by move=> /andP[]/eqP -> /He ->. + by move=> /andP[]/andP[] /eqP -> /He1 -> /He2 ->. - + rewrite -!/(sem_pexprs _ _). + + rewrite -!/(sem_pexprs _ _ _). by case/andP => /eqP <- /(eq_expr_recP Hes) ->. by move=> /andP[]/andP[]/andP[] /eqP -> /He -> /He1 -> /He2 ->. Qed. -Lemma eq_exprsP gd m es1 es2: - all2 eq_expr es1 es2 → sem_pexprs gd m es1 = sem_pexprs gd m es2. +Lemma eq_exprsP wdb gd m es1 es2: + all2 eq_expr es1 es2 → sem_pexprs wdb gd m es1 = sem_pexprs wdb gd m es2. Proof. apply: eq_expr_recP => e _ e'; exact: eq_exprP. Qed. -Lemma pto_val_inj t (v1 v2:psem_t t) : pto_val v1 = pto_val v2 -> v1 = v2. -Proof. - case: t v1 v2 => //= [ | | p | sz ] v1 v2 => [ []|[] | /Varr_inj1 | ] //. - case: v1 v2 => sz1 w1 p1 [sz2 w2 p2] /=. - move=> /Vword_inj [e];subst => /= <-. - by rewrite (@eq_irrelevance _ _ _ p1 p2). -Qed. - -Lemma pto_val_undef t (v:psem_t t) t' h : pto_val v <> Vundef t' h. -Proof. by case: t v. Qed. - Lemma get_var_undef vm x v ty h : - get_var vm x = ok v -> v <> Vundef ty h. -Proof. - rewrite /get_var. - apply: on_vuP=> // t _ <-. - apply pto_val_undef. -Qed. + get_var true vm x = ok v -> v <> Vundef ty h. +Proof. by move=> /get_var_compat [] * ?; subst. Qed. Lemma get_gvar_undef gd vm x v ty h : - get_gvar gd vm x = ok v -> v <> Vundef ty h. + get_gvar true gd vm x = ok v -> v <> Vundef ty h. Proof. - rewrite /get_gvar. - case: is_lvar. - + by apply get_var_undef. + rewrite /get_gvar; case: is_lvar; first by apply get_var_undef. move=> /get_globalI [gv [_ -> _]]. by case: gv. Qed. -Lemma to_word_to_pword s v w: to_word s v = ok w -> to_pword s v = ok (pword_of_word w). -Proof. - case: v => //= [ s' w' | [] // ]. - move=> /truncate_wordP [hle] ?; subst w; f_equal. - case: Sumbool.sumbool_of_bool => //=. - move=> e;move: (e);rewrite cmp_le_eq_lt in e => e'. - case /orP: e => [hlt | /eqP ?];first by rewrite -cmp_nlt_le hlt in hle. - by subst; rewrite /pword_of_word zero_extend_u;do 2 f_equal;apply eq_irrelevance. -Qed. - -Lemma pword_of_word_uincl sz (x: word sz) (y: pword sz) : - @pval_uincl (sword sz) (sword sz) (pword_of_word x) y → - ∃ e : sz = pw_size y, pw_word y = ecast _ _ e x. -Proof. - case: y => sz' y sz'_le_sz. - case/andP => /(cmp_le_antisym sz'_le_sz) ? /=; subst. - move => /eqP -> {x}; exists erefl. - by rewrite zero_extend_u. - Qed. - -(* ------------------------------------------------------------------------------ *) -Definition apply_undef t (v : exec (psem_t t)) := - match v with - | Error ErrAddrUndef => pundef_addr t - | _ => v - end. - -Lemma eval_uincl_undef t1 t2 (v:psem_t t2) : - subtype t1 t2 -> - eval_uincl (pundef_addr t1) (ok v). -Proof. - case: t1 => //= p; case: t2 v => //= p2 a /eqP[] ->; split => // ??. - by rewrite WArray.get_empty; case: ifP. -Qed. - -Lemma apply_undef_pundef_addr t : apply_undef (pundef_addr t) = pundef_addr t. -Proof. by case: t. Qed. - (* ------------------------------------------------------------------------------ *) Section SEM_CALL_PARAMS. @@ -2690,33 +2310,11 @@ Context (* ** Semantic without stack * -------------------------------------------------------------------- *) -Lemma exec_syscallPu scs m o vargs vargs' rscs rm vres : - sem.exec_syscall scs m o vargs = ok (rscs, rm, vres) → - List.Forall2 value_uincl vargs vargs' → - exists2 vres' : values, - sem.exec_syscall scs m o vargs' = ok (rscs, rm, vres') & List.Forall2 value_uincl vres vres'. -Proof. - rewrite /sem.exec_syscall; case: o => [ p ]. - t_xrbindP => -[scs' v'] /= h ??? hu; subst scs' m v'. - move: h; rewrite /exec_getrandom. - case: hu => // va va' ?? /of_value_uincl_te h [] //. - t_xrbindP => a /h{h}[? /= -> ?] ra hra ??; subst rscs vres. - by rewrite hra /=; eexists; eauto. -Qed. - -Lemma exec_syscallSu scs m o vargs rscs rm vres : - sem.exec_syscall scs m o vargs = ok (rscs, rm, vres) → - mem_equiv m rm. -Proof. - rewrite /sem.exec_syscall; case: o => [ p ]. - by t_xrbindP => -[scs' v'] /= _ _ <- _. -Qed. - #[ global ] Instance sCP_unit : semCallParams (pT := progUnit) := { init_state := fun _ _ _ s => ok s; finalize := fun _ m => m; - exec_syscall := sem.exec_syscall; + exec_syscall := exec_syscall_u; exec_syscallP := exec_syscallPu; exec_syscallS := exec_syscallSu; }. @@ -2729,8 +2327,8 @@ Definition init_stk_state (sf : stk_fun_extra) (pe:sprog_extra) (wrip:pointer) ( let m1 := s.(emem) in let vm1 := s.(evm) in Let m1' := alloc_stack m1 sf.(sf_align) sf.(sf_stk_sz) sf.(sf_stk_ioff) sf.(sf_stk_extra_sz) in - write_vars [:: vid pe.(sp_rsp) ; vid pe.(sp_rip)] - [:: Vword (top_stack m1'); Vword wrip] (Estate scs1 m1' vmap0). + write_vars true [:: vid pe.(sp_rsp) ; vid pe.(sp_rip)] + [:: Vword (top_stack m1'); Vword wrip] (Estate scs1 m1' Vm.init). Definition finalize_stk_mem (sf : stk_fun_extra) (m:mem) := free_stack m. @@ -2744,164 +2342,15 @@ Instance sCP_stack : semCallParams (pT := progStack) := exec_syscallS := exec_syscallSs; }. -(* -------------------------------------------------------------------- *) - -(* FIXME : MOVE THIS, this should be an invariant in vmap *) -Section WF. - - Context - {T : eqType} - {pT : progT T} - {sCP : semCallParams} - (p : prog) - (ev : extra_val_t). - - Definition wf_vm (vm:vmap) := - forall x, - match vm.[x]%vmap, vtype x with - | Ok _ , _ => True - | Error ErrAddrUndef, sarr _ => False - | Error ErrAddrUndef, _ => True - | _, _ => false - end. - - Lemma wf_vm_set (vm: vmap) (x: var) (v: psem_t (vtype x)) : - wf_vm vm → - wf_vm vm.[x <- ok v]%vmap. - Proof. - move => h y; rewrite Fv.setP; case: eqP => x_y; first by subst. - exact: h. - Qed. - - Lemma wf_set_var x ve vm1 vm2 : - wf_vm vm1 -> set_var vm1 x ve = ok vm2 -> wf_vm vm2. - Proof. - move=> Hwf;apply: set_varP => [v | _ ] ? <- /= z. - + exact: wf_vm_set. - rewrite Fv.setP; case: eqP => x_z. - + by subst; case: (vtype z). - exact: Hwf. - Qed. - - Lemma wf_write_var x ve s1 s2 : - wf_vm (evm s1) -> write_var x ve s1 = ok s2 -> wf_vm (evm s2). - Proof. - by move=> HWf; apply: rbindP => vm Hset [<-] /=;apply: wf_set_var Hset. - Qed. - - Lemma wf_write_vars x ve s1 s2 : - wf_vm (evm s1) -> write_vars x ve s1 = ok s2 -> wf_vm (evm s2). - Proof. - elim: x ve s1 s2=> [ | x xs Hrec] [ | e es] //= s1 s2. - + by move=> ? [<-]. - by move=> Hwf; apply: rbindP => vm /(wf_write_var Hwf) -/Hrec H/H. - Qed. - - Lemma wf_write_lval gd x ve s1 s2 : - wf_vm (evm s1) -> write_lval gd x ve s1 = ok s2 -> wf_vm (evm s2). - Proof. - case: x => [vi t|v|sz v e|aa sz v e|aa sz len v e] /= Hwf. - + by move=> /write_noneP [->]. + by apply wf_write_var. + by t_rbindP => -[<-]. - + apply: on_arr_varP => n t ? ?. - apply:rbindP => ??;apply:rbindP => ??;apply:rbindP => ??. - by apply:rbindP=>? Hset [<-] /=;apply: wf_set_var Hset. - apply: on_arr_varP => n t ? ?. - apply:rbindP => ??;apply:rbindP => ??;apply:rbindP => ??. - by apply:rbindP=>? Hset [<-] /=;apply: wf_set_var Hset. - Qed. - - Lemma wf_write_lvals gd xs vs s1 s2 : - wf_vm (evm s1) -> write_lvals gd s1 xs vs = ok s2 -> wf_vm (evm s2). - Proof. - elim: xs vs s1 => [ | x xs Hrec] [ | v vs] s1 //= Hwf => [[<-]//| ]. - apply: rbindP => s1' /(wf_write_lval Hwf);apply Hrec. - Qed. - - Let Pr i := - forall s1 s2, sem_i p ev s1 i s2 -> wf_vm (evm s1) -> wf_vm (evm s2). - - Let Pi i := - forall s1 s2, sem_I p ev s1 i s2 -> wf_vm (evm s1) -> wf_vm (evm s2). - - Let Pc c := - forall s1 s2, sem p ev s1 c s2 -> wf_vm (evm s1) -> wf_vm (evm s2). - - Lemma wf_sem s1 c s2 : - sem p ev s1 c s2 -> wf_vm (evm s1) -> wf_vm (evm s2). - Proof. - apply: (cmd_rect (Pr := Pr) (Pi := Pi) (Pc := Pc)) => {s1 s2 c}. - + by move=> i ii Hrec s1 s2 /sem_IE; apply: Hrec. - + by move => s1 s2 /semE ->. - + by move=> i c Hi Hc s1 s2 /semE [si] [] /Hi {Hi} Hi ? /Hi; apply: Hc. - + move=> x t ty e s1 s2 /sem_iE [v] [v'] [hv hv' ok_s2] hw. - by apply: wf_write_lval ok_s2. - + move=> xs t o es s1 s2 /sem_iE. - by apply:rbindP => ?? Hw ?;apply: wf_write_lvals Hw. - + by move=> xs o es s1 s2 /sem_iE [scs [m [ves [vs [_ _ hw]]]]] hu; apply: wf_write_lvals hw. - + move=> e c1 c2 Hc1 Hc2 s1 s2 /sem_iE [b] [_]; case: b; [apply Hc1 | apply Hc2]. - + move=> i dir lo hi c Hc s1 s2 /sem_iE [vlo] [vhi] [hlo hhi hfor]. - elim: hfor Hc => // ???? ???? Hw Hsc Hsf Hrec Hc. - by move=> /wf_write_var -/(_ _ _ _ Hw) -/(Hc _ _ Hsc);apply: Hrec Hc. - + move=> a c e c' Hc Hc' s1 s2 H. - move: {1 2}(Cwhile a c e c') H (refl_equal (Cwhile a c e c'))=> i;elim=> //=. - move=> ???????? Hsc ? Hsc' Hsw Hrec [????];subst. - move=> /(Hc _ _ Hsc). - by move=> /(Hc' _ _ Hsc'); apply Hrec. - + move=> ?????? Hsc ? [????];subst. - exact: (Hc _ _ Hsc). - move=> i xs f es s1 s2 /sem_iE [vs] [scs2] [m2] [rs] [_ _ ok_s2] hw. - by apply: wf_write_lvals ok_s2. - Qed. - - Lemma wf_vm_uincl vm : wf_vm vm -> vm_uincl vmap0 vm. - Proof. - move=> Hwf x;have := Hwf x;rewrite /vmap0 Fv.get0. - case: vm.[x]%vmap => [a _ | ];first by apply eval_uincl_undef. - move=> [] //=;case:(vtype x) => //=. - Qed. - - Lemma wf_vmap0 : wf_vm vmap0. - Proof. by move=> x;rewrite /vmap0 Fv.get0;case:vtype. Qed. - - Definition wf_init := forall fe pe ev s1 s2, - init_state fe pe ev s1 = ok s2 -> - wf_vm (evm s1) -> wf_vm (evm s2). - - Lemma wf_sem_I s1 i s2 : - sem_I p ev s1 i s2 -> wf_vm (evm s1) -> wf_vm (evm s2). - Proof. by move=> H;have := sem_seq1 H; apply: wf_sem. Qed. - -End WF. - -#[ global ] Arguments wf_init { T pT }. - -Lemma wf_initu : wf_init sCP_unit. -Proof. by move=> ????? [->]. Qed. - -Lemma wf_inits : wf_init sCP_stack. -Proof. - move=> ????? => /=; rewrite /init_stk_state; t_xrbindP => ?? h1 h2. - apply: wf_write_vars h1; apply wf_vmap0. -Qed. - End SEM_CALL_PARAMS. End WITH_PARAMS. -(* We redefine the notations outside the section so that we can use them in other files *) -Notation "vm1 '<=[' s ']' vm2" := (vmap_uincl_on s vm1 vm2) (at level 70, vm2 at next level, - format "'[hv ' vm1 <=[ s ] '/' vm2 ']'"). - -Notation "vm1 '<=[\' s ']' vm2" := (vmap_uincl_ex s vm1 vm2) (at level 70, vm2 at next level, - format "'[hv ' vm1 <=[\ s ] '/' vm2 ']'"). - -(* Same thing for the hints *) -#[ export ] Hint Resolve - word_uincl_refl - value_uincl_refl - val_uincl_refl - pval_uincl_refl - eval_uincl_refl - vm_uincl_refl - vmap_uincl_on_empty - : core. +End WSW. + +Ltac t_get_var := + repeat ( + rewrite get_var_eq + || (rewrite get_var_neq; last by [|apply/nesym]) + ). + diff --git a/proofs/lang/psem_defs.v b/proofs/lang/psem_defs.v new file mode 100644 index 000000000..7effbbd59 --- /dev/null +++ b/proofs/lang/psem_defs.v @@ -0,0 +1,231 @@ +(* * Jasmin semantics with “partial values”. *) + +(* ** Imports and settings *) +From mathcomp Require Import all_ssreflect all_algebra. +Require Import Psatz xseq. +Require Export array type expr gen_map low_memory warray_ sem_type sem_op_typed values varmap expr_facts low_memory syscall_sem. +Require Export + flag_combination + sem_params. +Import Utf8. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope Z_scope. +Local Open Scope seq_scope. +Open Scope vm_scope. + +(* ** Parameter expressions + * -------------------------------------------------------------------- *) + +Definition sem_sop1 (o: sop1) (v: value) : exec value := + let t := type_of_op1 o in + Let x := of_val _ v in + ok (to_val (sem_sop1_typed o x)). + +Definition sem_sop2 (o: sop2) (v1 v2: value) : exec value := + let t := type_of_op2 o in + Let x1 := of_val _ v1 in + Let x2 := of_val _ v2 in + Let r := sem_sop2_typed o x1 x2 in + ok (to_val r). + +Definition sem_opN + {cfcd : FlagCombinationParams} (op: opN) (vs: values) : exec value := + Let w := app_sopn _ (sem_opN_typed op) vs in + ok (to_val w). + +(* ** Global access + * -------------------------------------------------------------------- *) +Definition get_global_value (gd: glob_decls) (g: var) : option glob_value := + assoc gd g. + +Definition gv2val (gd:glob_value) := + match gd with + | Gword ws w => Vword w + | Garr p a => Varr a + end. + +Definition get_global gd g : exec value := + if get_global_value gd g is Some ga then + let v := gv2val ga in + if type_of_val v == vtype g then ok v + else type_error + else type_error. + +Section WSW. +Context {wsw:WithSubWord}. + +(* ** State + * ------------------------------------------------------------------------- *) + +Record estate + {syscall_state : Type} + {ep : EstateParams syscall_state} := Estate + { + escs : syscall_state; + emem : mem; + evm : Vm.t + }. + +Arguments Estate {syscall_state}%type_scope {ep} _ _ _%vm_scope. + +(* ** Variable map + * -------------------------------------------------------------------- *) + +Definition get_gvar (wdb : bool) (gd : glob_decls) (vm : Vm.t) (x : gvar) := + if is_lvar x then get_var wdb vm x.(gv) + else get_global gd x.(gv). + +Definition on_arr_var A (v:exec value) (f:forall n, WArray.array n -> exec A) := + Let v := v in + match v with + | Varr n t => f n t + | _ => type_error + end. + +Notation "'Let' ( n , t ) ':=' wdb ',' s '.[' v ']' 'in' body" := + (@on_arr_var _ (get_var wdb s.(evm) v) (fun n (t:WArray.array n) => body)) (at level 25, s at level 0). + +Notation "'Let' ( n , t ) ':=' wdb ',' gd ',' s '.[' v ']' 'in' body" := + (@on_arr_var _ (get_gvar wdb gd s.(evm) v) (fun n (t:WArray.array n) => body)) (at level 25, gd at level 0, s at level 0). + +Section ESTATE_UTILS. + +Context + {syscall_state : Type} + {ep : EstateParams syscall_state}. + +Definition with_vm (s:estate) vm := + {| escs := s.(escs); emem := s.(emem); evm := vm |}. + +Definition with_mem (s:estate) m := + {| escs := s.(escs); emem := m; evm := s.(evm) |}. + +Definition with_scs (s:estate) scs := + {| escs := scs; emem := s.(emem); evm := s.(evm) |}. + +End ESTATE_UTILS. + +Section SEM_PEXPR. + +Context + {asm_op syscall_state : Type} + {ep : EstateParams syscall_state} + {spp : SemPexprParams} + (wdb : bool) + (gd : glob_decls). + +Fixpoint sem_pexpr (s:estate) (e : pexpr) : exec value := + match e with + | Pconst z => ok (Vint z) + | Pbool b => ok (Vbool b) + | Parr_init n => ok (Varr (WArray.empty n)) + | Pvar v => get_gvar wdb gd s.(evm) v + | Pget aa ws x e => + Let (n, t) := wdb, gd, s.[x] in + Let i := sem_pexpr s e >>= to_int in + Let w := WArray.get aa ws t i in + ok (Vword w) + | Psub aa ws len x e => + Let (n, t) := wdb, gd, s.[x] in + Let i := sem_pexpr s e >>= to_int in + Let t' := WArray.get_sub aa ws len t i in + ok (Varr t') + | Pload sz x e => + Let w1 := get_var wdb s.(evm) x >>= to_pointer in + Let w2 := sem_pexpr s e >>= to_pointer in + Let w := read s.(emem) (w1 + w2)%R sz in + ok (@to_val (sword sz) w) + | Papp1 o e1 => + Let v1 := sem_pexpr s e1 in + sem_sop1 o v1 + | Papp2 o e1 e2 => + Let v1 := sem_pexpr s e1 in + Let v2 := sem_pexpr s e2 in + sem_sop2 o v1 v2 + | PappN op es => + Let vs := mapM (sem_pexpr s) es in + sem_opN op vs + | Pif t e e1 e2 => + Let b := sem_pexpr s e >>= to_bool in + Let v1 := sem_pexpr s e1 >>= truncate_val t in + Let v2 := sem_pexpr s e2 >>= truncate_val t in + ok (if b then v1 else v2) + end. + +Definition sem_pexprs s := mapM (sem_pexpr s). + +Definition write_var (x:var_i) (v:value) (s:estate) : exec estate := + Let vm := set_var wdb s.(evm) x v in + ok (with_vm s vm). + +Definition write_vars xs vs s := + fold2 ErrType write_var xs vs s. + +Definition write_none (s : estate) ty v := + Let _ := assert (truncatable wdb ty v) ErrType in + Let _ := assert (DB wdb v) ErrAddrUndef in + ok s. + +Definition write_lval (l : lval) (v : value) (s : estate) : exec estate := + match l with + | Lnone _ ty => write_none s ty v + | Lvar x => write_var x v s + | Lmem sz x e => + Let vx := get_var wdb (evm s) x >>= to_pointer in + Let ve := sem_pexpr s e >>= to_pointer in + let p := (vx + ve)%R in (* should we add the size of value, i.e vx + sz * se *) + Let w := to_word sz v in + Let m := write s.(emem) p w in + ok (with_mem s m) + | Laset aa ws x i => + Let (n,t) := wdb, s.[x] in + Let i := sem_pexpr s i >>= to_int in + Let v := to_word ws v in + Let t := WArray.set t aa i v in + write_var x (@to_val (sarr n) t) s + | Lasub aa ws len x i => + Let (n,t) := wdb, s.[x] in + Let i := sem_pexpr s i >>= to_int in + Let t' := to_arr (Z.to_pos (arr_size ws len)) v in + Let t := @WArray.set_sub n aa ws len t i t' in + write_var x (@to_val (sarr n) t) s + end. + +Definition write_lvals (s : estate) xs vs := + fold2 ErrType write_lval xs vs s. + +End SEM_PEXPR. + +Section EXEC_ASM. + +Context + {asm_op syscall_state : Type} + {ep : EstateParams syscall_state} + {spp : SemPexprParams} + {asmop : asmOp asm_op}. + +Definition exec_sopn (o:sopn) (vs:values) : exec values := + let semi := sopn_sem o in + Let t := app_sopn _ semi vs in + ok (list_ltuple t). + +Definition sem_sopn gd o m lvs args := + sem_pexprs true gd m args >>= exec_sopn o >>= write_lvals true gd m lvs. + +End EXEC_ASM. + +End WSW. + +(* Just for extraction *) +Definition syscall_sem__ := @syscall_sem.exec_syscall_u. + +Notation "'Let' ( n , t ) ':=' wdb ',' s '.[' v ']' 'in' body" := + (@on_arr_var _ (get_var wdb s.(evm) v) (fun n (t:WArray.array n) => body)) (at level 25, s at level 0). + +Notation "'Let' ( n , t ) ':=' wdb ',' gd ',' s '.[' v ']' 'in' body" := + (@on_arr_var _ (get_gvar wdb gd s.(evm) v) (fun n (t:WArray.array n) => body)) (at level 25, gd at level 0, s at level 0). + diff --git a/proofs/lang/psem_facts.v b/proofs/lang/psem_facts.v index dd85a5726..aad9bb031 100644 --- a/proofs/lang/psem_facts.v +++ b/proofs/lang/psem_facts.v @@ -10,68 +10,39 @@ Unset Printing Implicit Defensive. Section WITH_PARAMS. Context + {wsw:WithSubWord} + {dc:DirectCall} {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} {sip : SemInstrParams asm_op syscall_state}. -Lemma write_lvals_write_lval gd lv v s : - write_lval gd lv v s = write_lvals gd s [:: lv ] [:: v ]. -Proof. rewrite /=. by case: write_lval. Qed. +Lemma write_lvals_write_lval wdb gd lv v s : + write_lval wdb gd lv v s = write_lvals wdb gd s [:: lv ] [:: v ]. +Proof. by rewrite /=; case: write_lval. Qed. -Lemma write_var_emem x v s s' : - write_var x v s = ok s' → - emem s = emem s'. -Proof. by rewrite /write_var; t_xrbindP => vm _ <-; rewrite emem_with_vm. Qed. - -Lemma write_vars_emem xs vs a z : - write_vars xs vs a = ok z → - emem a = emem z. -Proof. - elim: xs vs a => [ | x xs ih ] [] //. - - by move => a [<-]. - by move => v vs a /=; t_xrbindP => b /write_var_emem -> /ih. -Qed. - -Lemma get_var_write_var_word s s' ws (w : word ws) x : +Lemma get_write_var_word wdb s s' ws (w : word ws) x : vtype (v_var x) = sword ws - -> write_var x (Vword w) s = ok s' - -> get_var (evm s') (v_var x) = ok (Vword w). -Proof. - move=> hty. - rewrite /write_var. - t_xrbindP=> vm hset ?; subst s'. - rewrite (get_var_set_var _ hset). - rewrite hty /=. - by rewrite eqxx sumbool_of_boolET. -Qed. - -Lemma get_var_write_var_word_neq s s' x y v : - v_var x <> y - -> write_var x v s = ok s' - -> get_var (evm s') y = get_var (evm s) y. + -> write_var wdb x (Vword w) s = ok s' + -> (evm s').[v_var x] = Vword w. Proof. - move=> hxy. - rewrite /write_var. - t_xrbindP=> vm hset ?; subst s'. - rewrite (get_var_set_var _ hset). - by move: hxy => /eqP /negbTE ->. + by move=> hty /write_varP [-> _ _]; rewrite /= Vm.setP_eq /= hty cmp_le_refl !orbT. Qed. Lemma vrvs_Lvar xs : vrvs [seq Lvar x | x <- xs] = sv_of_list v_var xs. Proof. rewrite /vrvs /sv_of_list; elim: xs Sv.empty => //=. Qed. -Lemma write_vars_eq_except xs vs s s' : - write_vars xs vs s = ok s' → - evm s = evm s' [\ sv_of_list v_var xs]. +Lemma write_vars_eq_ex wdb xs vs s s' : + write_vars wdb xs vs s = ok s' → + evm s =[\ sv_of_list v_var xs] evm s' . Proof. - by rewrite (write_vars_lvals [::]) => /vrvsP; rewrite vrvs_Lvar. + by rewrite (write_vars_lvals _ [::]) => /vrvsP; rewrite vrvs_Lvar. Qed. -Lemma write_lvals_emem gd xs ys s vs s' : +Lemma write_lvals_emem wdb gd xs ys s vs s' : mapM get_lvar xs = ok ys → - write_lvals gd s xs vs = ok s' → + write_lvals wdb gd s xs vs = ok s' → emem s' = emem s. Proof. elim: xs ys vs s; first by move => _ [] // ? _ [] ->. @@ -79,8 +50,8 @@ Proof. by case: x X Y => // x _; rewrite /= /write_var; t_xrbindP => ?? <-. Qed. -Lemma write_lvals_escs gd xs s vs s' : - write_lvals gd s xs vs = ok s' → +Lemma write_lvals_escs wdb gd xs s vs s' : + write_lvals wdb gd s xs vs = ok s' → escs s' = escs s. Proof. elim: xs vs s => [ | x xs ih] /= [] // => [ _ [->] //| v vs s]. @@ -90,44 +61,40 @@ Qed. (* sem_stack_stable and sem_validw_stable both for uprog and sprog *) (* inspired by sem_one_varmap_facts *) -Lemma write_lval_stack_stable gd x v s s' : - write_lval gd x v s = ok s' → +Lemma write_lval_stack_stable wdb gd x v s s' : + write_lval wdb gd x v s = ok s' → stack_stable (emem s) (emem s'). Proof. - case: x => [ vi ty | x | ws x e | aa ws x e | aa ws len x e ]. - - apply: on_vuP; first by move => _ _ ->. - by move => _; case: ifP => // _ [<-]. - - by move => /write_var_emem ->. + case: x => [ vi ty | x | ws x e | aa ws x e | aa ws len x e ] /=. + - by move=> /write_noneP [<-]. + - by move => /write_var_memP ->. - rewrite /=; t_xrbindP => ?????????? m' ok_m' <- /=. exact: write_mem_stable ok_m'. all: by apply: on_arr_varP; rewrite /write_var; t_xrbindP => ?????????????? <-. Qed. -Lemma write_lvals_stack_stable gd xs vs s s' : - write_lvals gd s xs vs = ok s' → +Lemma write_lvals_stack_stable wdb gd xs vs s s' : + write_lvals wdb gd s xs vs = ok s' → stack_stable (emem s) (emem s'). Proof. elim: xs vs s => [ | x xs ih ] [] //; first by move => ? [<-]. by move => v vs s /=; t_xrbindP => ? /write_lval_stack_stable -> /ih. Qed. -Lemma write_lval_validw gd x v s s' : - write_lval gd x v s = ok s' -> +Lemma write_lval_validw wdb gd x v s s' : + write_lval wdb gd x v s = ok s' -> validw (emem s) =2 validw (emem s'). Proof. - case: x => /=. - - by move => _ ty /write_noneP [] <-. - - by move => x /write_var_emem <-. - - t_xrbindP => /= ????? ?? ?? ? ? ? ? ? h <- /=. + case: x => [ vi ty | x | ws x e | aa ws x e | aa ws len x e ] /=. + - by move => /write_noneP [] <-. + - by move => /write_var_memP <-. + - t_xrbindP => /= ?? ?? ?? ? ? ? ? ? h <- /=. by move=> ??; rewrite (write_validw_eq h). - - move => aa sz x e. - by apply: on_arr_varP; rewrite /write_var; t_xrbindP => ?????????????? <-. - move => aa sz ty x e. - by apply: on_arr_varP; rewrite /write_var; t_xrbindP => ?????????????? <-. + all: by apply: on_arr_varP; rewrite /write_var; t_xrbindP => ?????????????? <-. Qed. -Lemma write_lvals_validw gd xs vs s s' : - write_lvals gd s xs vs = ok s' -> +Lemma write_lvals_validw wdb gd xs vs s s' : + write_lvals wdb gd s xs vs = ok s' -> validw (emem s) =2 validw (emem s'). Proof. elim: xs vs s. @@ -256,7 +223,7 @@ Proof. by []. Qed. Lemma mem_equiv_for_cons : sem_Ind_for_cons P ev Pc Pfor. Proof. - move => ???????? /write_var_emem A _ B _ C; red. + move => ???????? /write_var_memP A _ B _ C; red. rewrite A; etransitivity; [ exact: B | exact: C ]. Qed. @@ -266,7 +233,7 @@ Proof. move=> s1 scs2 m2 s2 ii xs fn args vargs vres _ _ ? /dup[] /write_lvals_v Lemma mem_equiv_proc : sem_Ind_proc P ev Pc Pfun. Proof. move=> scs1 m1 scs2 m2 fn fd vargs vargs' s0 s1 s2 vres vres' ok_fd ok_vargs ok_s0 ok_s1 _ Hc _ _ -> ->. - rewrite /Pc -(write_vars_emem ok_s1) in Hc. + rewrite /Pc -(write_vars_memP ok_s1) in Hc. by apply (init_finalize_mem_equiv ok_s0 Hc). Qed. @@ -421,7 +388,8 @@ Lemma sem_stack_stable_sprog (p : sprog) (gd : pointer) s1 c s2 : Proof. apply sem_mem_equiv => {s1 c s2}. move=> s1 s2 m2 ef /=; rewrite /init_stk_state /finalize_stk_mem. - t_xrbindP=> m1 /Memory.alloc_stackP hass [<-] /= [hss hvalid]. + t_xrbindP=> m1 /Memory.alloc_stackP hass /=. + do 2!rewrite write_var_eq_type //=; move=> [<-] /= [hss hvalid]. have hfss := Memory.free_stackP m2. split. + by apply (alloc_free_stack_stable hass hss hfss). @@ -433,7 +401,8 @@ Lemma sem_validw_stable_sprog (p : sprog) (gd : pointer) s1 c s2 : Proof. apply sem_mem_equiv => {s1 c s2}. move=> s1 s2 m2 ef /=; rewrite /init_stk_state /finalize_stk_mem. - t_xrbindP=> m1 /Memory.alloc_stackP hass [<-] /= [hss hvalid]. + t_xrbindP=> m1 /Memory.alloc_stackP hass /=. + do 2!rewrite write_var_eq_type //=; move=> [<-] /= [hss hvalid]. have hfss := Memory.free_stackP m2. split. + by apply (alloc_free_stack_stable hass hss hfss). @@ -445,7 +414,8 @@ Lemma sem_i_stack_stable_sprog (p : sprog) (gd : pointer) s1 c s2 : Proof. apply sem_i_mem_equiv => {s1 c s2}. move=> s1 s2 m2 ef /=; rewrite /init_stk_state /finalize_stk_mem. - t_xrbindP=> m1 /Memory.alloc_stackP hass [<-] /= [hss hvalid]. + t_xrbindP=> m1 /Memory.alloc_stackP hass /=. + do 2!rewrite write_var_eq_type //=; move=> [<-] /= [hss hvalid]. have hfss := Memory.free_stackP m2. split. + by apply (alloc_free_stack_stable hass hss hfss). @@ -457,7 +427,8 @@ Lemma sem_i_validw_stable_sprog (p : sprog) (gd : pointer) s1 c s2 : Proof. apply sem_i_mem_equiv => {s1 c s2}. move=> s1 s2 m2 ef /=; rewrite /init_stk_state /finalize_stk_mem. - t_xrbindP=> m1 /Memory.alloc_stackP hass [<-] /= [hss hvalid]. + t_xrbindP=> m1 /Memory.alloc_stackP hass /=. + do 2!rewrite write_var_eq_type //=; move=> [<-] /= [hss hvalid]. have hfss := Memory.free_stackP m2. split. + by apply (alloc_free_stack_stable hass hss hfss). @@ -469,7 +440,8 @@ Lemma sem_I_stack_stable_sprog (p : sprog) (gd : pointer) s1 c s2 : Proof. apply sem_I_mem_equiv => {s1 c s2}. move=> s1 s2 m2 ef /=; rewrite /init_stk_state /finalize_stk_mem. - t_xrbindP=> m1 /Memory.alloc_stackP hass [<-] /= [hss hvalid]. + t_xrbindP=> m1 /Memory.alloc_stackP hass /=. + do 2!rewrite write_var_eq_type //=; move=> [<-] /= [hss hvalid]. have hfss := Memory.free_stackP m2. split. + by apply (alloc_free_stack_stable hass hss hfss). @@ -481,7 +453,8 @@ Lemma sem_I_validw_stable_sprog (p : sprog) (gd : pointer) s1 c s2 : Proof. apply sem_I_mem_equiv => {s1 c s2}. move=> s1 s2 m2 ef /=; rewrite /init_stk_state /finalize_stk_mem. - t_xrbindP=> m1 /Memory.alloc_stackP hass [<-] /= [hss hvalid]. + t_xrbindP=> m1 /Memory.alloc_stackP hass /=. + do 2!rewrite write_var_eq_type //=; move=> [<-] /= [hss hvalid]. have hfss := Memory.free_stackP m2. split. + by apply (alloc_free_stack_stable hass hss hfss). @@ -493,7 +466,8 @@ Lemma sem_call_stack_stable_sprog (p : sprog) (gd : pointer) scs1 m1 fn vargs sc Proof. apply sem_call_mem_equiv => {scs1 m1 fn vargs scs2 m2 vres}. move=> s1 s2 m2 ef /=; rewrite /init_stk_state /finalize_stk_mem. - t_xrbindP=> m1 /Memory.alloc_stackP hass [<-] /= [hss hvalid]. + t_xrbindP=> m1 /Memory.alloc_stackP hass /=. + do 2!rewrite write_var_eq_type //=; move=> [<-] /= [hss hvalid]. have hfss := Memory.free_stackP m2. split. + by apply (alloc_free_stack_stable hass hss hfss). @@ -506,7 +480,8 @@ Lemma sem_call_validw_stable_sprog (p : sprog) (gd : pointer) scs1 m1 fn vargs s Proof. apply sem_call_mem_equiv => {scs1 m1 fn vargs scs2 m2 vres}. move=> s1 s2 m2 ef /=; rewrite /init_stk_state /finalize_stk_mem. - t_xrbindP=> m1 /Memory.alloc_stackP hass [<-] /= [hss hvalid]. + t_xrbindP=> m1 /Memory.alloc_stackP hass /=. + do 2!rewrite write_var_eq_type //=; move=> [<-] /= [hss hvalid]. have hfss := Memory.free_stackP m2. split. + by apply (alloc_free_stack_stable hass hss hfss). @@ -714,9 +689,9 @@ Qed. End DETERMINISM. (* ------------------------------------------------------------------- *) -Lemma cast_wP sz e gd s v : - sem_pexpr gd s (Papp1 (Oword_of_int sz) e) = ok v → - exists2 v', sem_pexpr gd s (cast_w sz e) = ok v' & value_uincl v v'. +Lemma cast_wP wdb sz e gd s v : + sem_pexpr wdb gd s (Papp1 (Oword_of_int sz) e) = ok v → + exists2 v', sem_pexpr wdb gd s (cast_w sz e) = ok v' & value_uincl v v'. Proof. elim: e v => /=; t_xrbindP => //. 1, 2: by move => > ->; eauto. @@ -759,99 +734,4 @@ Proof. by rewrite wsub_zero_extend // !zero_extend_u wrepr_sub. Qed. -Section USE_MEM. - -(* Solve [ h : vm =[ read e ] vm' |- vm =[ read e' ] vm'] with [e'] a - subexpression of [e]. *) -#[local] -Ltac t_vm_eq_on_read_e := - apply: eq_onI; - last eassumption; - rewrite ?read_e_Papp2 ?read_e_Pif ?read_e_PappN_cons /=; - by - [ done - | eauto 1 using SvP.MP.union_subset_1, SvP.MP.union_subset_2 - | SvD.fsetdec - ]. - -Lemma eq_on_sem_pexpr_nomem gd s s' e : - ~~ use_mem e - -> evm s =[ read_e e ] evm s' - -> sem_pexpr gd s e = sem_pexpr gd s' e. -Proof. - elim: e => - [||| x - | aa ws x e hinde - | aa ws len x e hinde - || op1 e hinde - | op2 e0 hinde0 e1 hinde1 - | opn es hindes - | ty e hinde e0 hinde0 e1 hinde1 - ] //= hmem hvm. - - - clear hmem. apply: (get_gvar_eq_on _ _ hvm). by rewrite read_e_var. - - - rewrite read_e_Pget in hvm. - rewrite (on_arr_gvar_eq_on (s' := s') gd _ hvm _); - last exact: SvP.MP.union_subset_1. - rewrite (hinde hmem _) {hinde hmem}; first done. - by t_vm_eq_on_read_e. - - - rewrite read_e_Psub in hvm. - rewrite (on_arr_gvar_eq_on (s' := s') gd _ hvm _); - last exact: SvP.MP.union_subset_1. - rewrite (hinde hmem _) {hinde hmem}; first done. - by t_vm_eq_on_read_e. - - - by rewrite (hinde hmem hvm). - - - rewrite negb_or in hmem. - move: hmem => /andP [hmeme0 hmeme1]. - rewrite (hinde0 hmeme0); last by t_vm_eq_on_read_e. - rewrite (hinde1 hmeme1); first done. - by t_vm_eq_on_read_e. - - - have -> : - mapM (sem_pexpr gd s) es = mapM (sem_pexpr gd s') es. - + elim: es hindes hmem hvm => //= e es hind hindes hmem hvm. - rewrite negb_or in hmem. - move: hmem => /andP [hmeme hmemes]. - rewrite (hindes _ _ hmeme) {hmeme}; first last. - * by t_vm_eq_on_read_e. - * by left. - rewrite (hind _ hmemes) {hind hmemes}; - first done; - last by t_vm_eq_on_read_e. - move=> e0 he0. - apply: hindes. - by right. - done. - - rewrite !negb_or in hmem. - move: hmem => /andP [] /andP [] hmeme hmeme0 hmeme1. - rewrite (hinde hmeme) {hinde hmeme}; last by t_vm_eq_on_read_e. - rewrite (hinde0 hmeme0) {hinde0 hmeme0}; last by t_vm_eq_on_read_e. - rewrite (hinde1 hmeme1) {hinde1 hmeme1}; first done. - by t_vm_eq_on_read_e. -Qed. - -Lemma use_memP s1 s2 gd e : - evm s1 = evm s2 -> - ~~ use_mem e -> - sem_pexpr gd s1 e = sem_pexpr gd s2 e. -Proof. - move=> hvm hmem. - rewrite (eq_on_sem_pexpr_nomem (s' := s2) _ hmem); first done. - by rewrite hvm. -Qed. - -End USE_MEM. - End WITH_PARAMS. - -(* TODO: move? *) -Lemma pword_of_wordE (ws : wsize) (w : word ws) p : - {| pw_size := ws; pw_word := w; pw_proof := p; |} = pword_of_word w. -Proof. - by rewrite (Eqdep_dec.UIP_dec Bool.bool_dec p (cmp_le_refl _)). -Qed. diff --git a/proofs/lang/psem_of_sem_proof.v b/proofs/lang/psem_of_sem_proof.v index 753ef8378..31ad8f426 100644 --- a/proofs/lang/psem_of_sem_proof.v +++ b/proofs/lang/psem_of_sem_proof.v @@ -6,6 +6,7 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. +#[local] Existing Instance indirect_c. Section PROOF. Context @@ -13,129 +14,88 @@ Context {ep : EstateParams syscall_state} {spp : SemPexprParams} {sip : SemInstrParams asm_op syscall_state} - (p : uprog). + {T : eqType} + {pT : progT T} + {sCP : forall {wsw : WithSubWord}, semCallParams}. + +Variable (p:prog) (ev:extra_val_t). Notation gd := (p_globs p). -Definition word_sim (s: wsize) (w: word s) (w': pword s) : Prop := - w' = pword_of_word w. - -Definition val_sim t : sem_t t → psem_t t → Prop := - match t with - | sbool => eq - | sint => eq - | sarr n => eq - | sword s => @word_sim s - end. - -Definition exec_val_sim t (v: exec (sem_t t)) (v': exec (psem_t t)) : Prop := - match v, v' with - | Ok x, Ok x' => val_sim x x' - | Error e, Error e' => e = e' - | _, _ => False - end. - -Lemma exec_val_simE t v v' : - @exec_val_sim t v v' → - match v with - | Ok x => ∃ x', v' = ok x' ∧ val_sim x x' - | Error e => v' = Error e - end. -Proof. -case: v v' => //. -- move => x [] //; eauto. -by move => e [] // e' ->. -Qed. +Notation vmap_n := (Vm.t (wsw:= nosubword)). +Notation vmap_s := (Vm.t (wsw:= withsubword)). -Definition vmap_sim (vm: sem.vmap) (vm': psem.vmap) : Prop := - (∀ x : var, exec_val_sim vm.[x] vm'.[x])%vmap. +Notation estate_n := (estate (wsw:= nosubword)). +Notation estate_s := (estate (wsw:= withsubword)). -Lemma vmap0_sim : vmap_sim sem.vmap0 psem.vmap0. -Proof. by move => x; rewrite !Fv.get0; case: (vtype _). Qed. +#[local]Open Scope vm_scope. -Definition estate_sim (e: sem.estate) (e': psem.estate) : Prop := - [/\ sem.escs e = psem.escs e', sem.emem e = psem.emem e' & vmap_sim (sem.evm e) (psem.evm e')]. +Definition estate_sim (e: estate_n) (e': estate_s) : Prop := + [/\ escs e = escs e', emem e = emem e' & evm e =1 evm e']. -Lemma estate_sim_scs e e' scs : estate_sim e e' -> - estate_sim {| sem.escs := scs; sem.emem := sem.emem e; sem.evm := sem.evm e|} - (psem.with_scs e' scs). +Lemma estate_sim_scs e e' scs : + estate_sim e e' -> + estate_sim (with_scs e scs) (with_scs e' scs). Proof. by case => *; constructor. Qed. -Lemma estate_sim_mem e e' m : estate_sim e e' -> - estate_sim {| sem.escs := sem.escs e; sem.emem := m; sem.evm := sem.evm e|} - (psem.with_mem e' m). +Lemma estate_sim_mem e e' m : + estate_sim e e' -> + estate_sim (with_mem e m) (with_mem e' m). Proof. by case => *; constructor. Qed. - -Lemma val_sim_to_val t x x' : - @val_sim t x x' → - to_val x = pto_val x'. -Proof. -by case: t x x'; (move => ?? -> || move => ??? -> || move => ???? ->). -Qed. -Lemma of_val_sim t x v : - of_val t x = ok v → - exec_val_sim (ok v) (pof_val t x). +Lemma vmap0_sim : Vm.init (wsw:= nosubword) =1 Vm.init (wsw:= withsubword). +Proof. by move=> x; rewrite !Vm.initP. Qed. + +Lemma get_var_sim (vm : vmap_n) (vm' : vmap_s) : + vm =1 vm' → + ∀ x, get_var true vm x = get_var true vm' x. +Proof. by move=> heq x; rewrite /get_var heq. Qed. + +Lemma get_gvar_sim gd (vm : vmap_n) (vm' : vmap_s) : + vm =1 vm' → + ∀ x, get_gvar true gd vm x = get_gvar true gd vm' x. Proof. -move => h; rewrite -h; move: h. -case: t v => [ | | n | sz ]; case: x => //; try by case. -- by rewrite /exec_val_sim => n' t' t /= ->. -- move => sz' w' /= w h. - rewrite h /=. - case: (truncate_wordP h) => {h} hle ?; subst w. - case: Sumbool.sumbool_of_bool => // hle'. - have ? := cmp_le_antisym hle hle' => {hle}; subst. - by rewrite zero_extend_u pword_of_wordE. +by move => h x; rewrite /get_gvar (get_var_sim h). Qed. -Lemma of_val_undef_sim x : - of_val sbool x = undef_error → - exec_val_sim undef_error (pof_val sbool x). -Proof. by case: x => //= -[]. Qed. - -Lemma get_var_sim vm vm' : - vmap_sim vm vm' → - ∀ x, sem.get_var vm x = psem.get_var vm' x. +Lemma vm_truncate_val_sim t v : + truncatable true (wsw:=nosubword) t v → + vm_truncate_val (wsw:=nosubword) t v = + vm_truncate_val (wsw:=withsubword) t v. Proof. -move => h x; rewrite /sem.get_var /psem.get_var. -case: (vm.[x])%vmap (h x) => a /exec_val_simE. -- by case => a' [] -> ha /=; rewrite (val_sim_to_val ha). -by move => ->. + move=>/vm_truncate_valE; case: v => [b|z|len a|ws w|//]. + 1-3: by move=> [-> ]. + by move=> [ws' [-> ]] /=. Qed. -Lemma get_gvar_sim gd vm vm' : - vmap_sim vm vm' → - ∀ x, sem.get_gvar gd vm x = psem.get_gvar gd vm' x. +Lemma vmap_set_sim (vm : vmap_n) (vm' : vmap_s) x v: + vm =1 vm' → + truncatable true (wsw:=nosubword) (vtype x) v → + vm.[x <- v] =1 vm'.[x <- v]. Proof. -by move => h x; rewrite /sem.get_gvar /psem.get_gvar (get_var_sim h). + move => hvm hv y; rewrite !Vm.setP. + by rewrite vm_truncate_val_sim // hvm. Qed. -Lemma vmap_set_sim vm vm' x v v' : - vmap_sim vm vm' → - exec_val_sim v v' → - (vmap_sim vm.[x <- v] vm'.[x <- v'])%vmap. +Lemma truncatable_sim ty v : + truncatable true (wsw:= nosubword) ty v -> + truncatable true (wsw:= withsubword) ty v. Proof. -move => hvm hv y; case: (x =P y). -- by move => ?; subst; rewrite !Fv.setP_eq. -by move => /eqP ne; rewrite !(Fv.setP_neq _ _ ne). + move=> /vm_truncate_valE; case: (v) => [b|z|len a|ws w| t i] /=. + 1-3,5: by move=> [-> _] //=; rewrite eqxx. + by move=> [ws' [-> _ _]] /=. Qed. -Lemma set_var_sim vm1 vm1' x v vm2 : - vmap_sim vm1 vm1' → - sem.set_var vm1 x v = ok vm2 → +Lemma set_var_sim (vm1 : vmap_n) (vm1' : vmap_s) x v vm2 : + vm1 =1 vm1' → + set_var true vm1 x v = ok vm2 → ∃ vm2', - vmap_sim vm2 vm2' ∧ - psem.set_var vm1' x v = ok vm2'. + vm2 =1 vm2' ∧ + set_var true vm1' x v = ok vm2'. Proof. -move => h; rewrite /sem.set_var /psem.set_var; apply: on_vuP. -- move => t ht <- {vm2}. - case/exec_val_simE: (of_val_sim ht) => t' [-> htt'] /=. - eexists; split; last reflexivity. - exact: vmap_set_sim. -case: x => xt x;case: is_sboolP => //= ?;subst xt. -move => /of_val_undef_sim /exec_val_simE /= -> [<-] /=. -eexists; split; last reflexivity. -by apply: vmap_set_sim. + move=> hsim /set_varP [hdb /dup []htr /truncatable_sim htr' ->]. + rewrite (set_var_truncate hdb htr') //; eexists; split; last by eauto. + by apply vmap_set_sim. Qed. Section SEM_PEXPR_SIM. @@ -144,35 +104,27 @@ Section SEM_PEXPR_SIM. Let P e : Prop := ∀ v, - sem.sem_pexpr gd s e = ok v → - psem.sem_pexpr gd s' e = ok v. + sem_pexpr true gd s e = ok v → + sem_pexpr true gd s' e = ok v. Let Q es : Prop := ∀ vs, - sem.sem_pexprs gd s es = ok vs → - psem.sem_pexprs gd s' es = ok vs. - - Local Ltac sem_pexpr_sim_t := - repeat match goal with - | _ : ?a = ?b |- _ => subst a || subst b - | h : to_int _ = ok _ |- _ => apply of_valE in h - | h : ∀ x, _ → _ , k : _ |- _ => specialize (h _ k) => {k} - | h : ?p = ok _ |- _ => rewrite h /= => {h} - | hm: sem.emem _ = _, h : context[sem.emem _] |- _ => rewrite hm in h - | hvm: vmap_sim ?vm _, h : context[ sem.get_var ?vm _] |- _ => rewrite (get_var_sim hvm) in h - | hvm: vmap_sim ?vm _, h : context[ sem.get_gvar gd ?vm _] |- _ => rewrite (get_gvar_sim gd hvm) in h - | h : sem.on_arr_var _ _ = ok _ |- _ => unfold sem.on_arr_var in h; unfold sem.on_arr_var - | h : (if _ then _ else _) = ok _ |- _ => - move: h; case: eqP => // ->; rewrite eqxx - | h : Let x := _ in _ = ok _ |- _ => move: h; t_xrbindP => * - | h : match ?x with _ => _ end = ok _ |- _ => move: h; case: x => // * - end. + sem_pexprs true gd s es = ok vs → + sem_pexprs true gd s' es = ok vs. Lemma sem_pexpr_s_sim : (∀ e, P e) ∧ (∀ es, Q es). Proof. - case: hs => ???. - by apply: pexprs_ind_pair; subst P Q; split => //=; t_xrbindP => *; - rewrite -/(sem_pexprs _ _); sem_pexpr_sim_t. + case: hs => ? hmem hsim. + apply: pexprs_ind_pair; subst P Q; split => //=; t_xrbindP. + + by move=> ? he ? hes ?? /he -> ? /hes -> <-. + + by move=> ?? <-;apply/esym/get_gvar_sim. + 1,2: by move=> > he ?; rewrite /on_arr_var /on_arr_var (get_gvar_sim _ hsim); + t_xrbindP => -[] // > ->; t_xrbindP => > /he -> /= -> ? /= -> <-. + + by move=> > he >; rewrite (get_var_sim hsim) hmem => -> /= -> > /he -> /= -> > /= -> <-. + + by move=> > he > /he ->. + + by move=> > he1 > he2 > /he1 -> > /he2 ->. + + by move=> > hes > /hes; rewrite /sem_pexprs => ->. + by move=> > he > he1 > he2 > /he -> /= -> > /he1 -> /= -> > /he2 -> /= -> <-. Qed. End SEM_PEXPR_SIM. @@ -185,18 +137,18 @@ Definition sem_pexprs_sim s es vs s' h := Lemma write_var_sim s1 x v s2 s1' : estate_sim s1 s1' → - sem.write_var x v s1 = ok s2 → - ∃ s2', estate_sim s2 s2' ∧ psem.write_var x v s1' = ok s2'. + write_var true x v s1 = ok s2 → + ∃ s2', estate_sim s2 s2' ∧ write_var true x v s1' = ok s2'. Proof. -case => hscs hm hvm; rewrite /sem.write_var /psem.write_var; t_xrbindP => vm hw <- {s2}. +case => hscs hm hvm; rewrite /write_var; t_xrbindP => vm hw <- {s2}. case: (set_var_sim hvm hw) => vm' [hvm' ->]. by eexists; split; split. Qed. Corollary write_vars_sim s1 xs vs s2 s1' : estate_sim s1 s1' → - sem.write_vars xs vs s1 = ok s2 → - ∃ s2', estate_sim s2 s2' ∧ psem.write_vars xs vs s1' = ok s2'. + write_vars true xs vs s1 = ok s2 → + ∃ s2', estate_sim s2 s2' ∧ write_vars true xs vs s1' = ok s2'. Proof. elim: xs vs s1 s1' s2. - by case => // s1 s1' s2 h [<-]; exists s1'. @@ -205,28 +157,24 @@ Qed. Lemma write_lval_sim s1 x v s2 s1' : estate_sim s1 s1' → - sem.write_lval gd x v s1 = ok s2 → - ∃ s2', estate_sim s2 s2' ∧ psem.write_lval gd x v s1' = ok s2'. + write_lval true gd x v s1 = ok s2 → + ∃ s2', estate_sim s2 s2' ∧ write_lval true gd x v s1' = ok s2'. Proof. case => hscs hm hvm; case: x => /=. -- move => _ ty; rewrite /sem.write_none /psem.write_none; apply: on_vuP. - + move => w hw <- {s2}; exists s1'; split; first by []. - by case /exec_val_simE: (of_val_sim hw) => v' [-> _]. - case: is_sboolP => // ?;subst ty. - move /of_val_undef_sim => /exec_val_simE /= -> /= [<-]. - by exists s1'. +- move => _ ty; rewrite /write_none. + by t_xrbindP => /truncatable_sim -> -> <-; exists s1'. - move => x; exact: write_var_sim. - move => sz x e; t_xrbindP => ? ?; rewrite hm (get_var_sim hvm) => -> /= -> ?? /(sem_pexpr_sim (And3 hscs hm hvm)) -> /= -> ? -> ? /= -> <- /=. by eexists; split; split. - move => aa ws x e. - rewrite /on_arr_var (get_var_sim hvm); rewrite /sem.write_var /write_var; t_xrbindP => t -> /=. - case: t => // n t; t_xrbindP => ?? /(sem_pexpr_sim (And3 hscs hm hvm)) -> /= -> ? -> /= ? -> ? /(set_var_sim hvm). - case => vm' [] h /= -> <- /=. + rewrite /on_arr_var /on_arr_var (get_var_sim hvm) /write_var. + t_xrbindP => -[] // n t -> /=; t_xrbindP => ?? + /(sem_pexpr_sim (And3 hscs hm hvm)) -> /= -> ? -> /= ? -> ? /(set_var_sim hvm) /= [vm' [h ->]] <-. by eexists; split; split. move => aa ws ofs x e. -rewrite /on_arr_var (get_var_sim hvm); rewrite /sem.write_var /write_var; t_xrbindP => t -> /=. +rewrite /on_arr_var (get_var_sim hvm) /write_var; t_xrbindP => t -> /=. case: t => // n t; t_xrbindP => ?? /(sem_pexpr_sim (And3 hscs hm hvm)) -> /= -> ? -> /= ? -> ? /(set_var_sim hvm). case => vm' [] h /= -> <- /=. by eexists; split; split. @@ -234,8 +182,8 @@ Qed. Corollary write_lvals_sim s1 xs vs s2 s1' : estate_sim s1 s1' → - sem.write_lvals gd s1 xs vs = ok s2 → - ∃ s2', estate_sim s2 s2' ∧ psem.write_lvals gd s1' xs vs = ok s2'. + write_lvals true gd s1 xs vs = ok s2 → + ∃ s2', estate_sim s2 s2' ∧ write_lvals true gd s1' xs vs = ok s2'. Proof. elim: xs vs s1 s1'. - by case => // ? ? h [<-]; eauto. @@ -247,34 +195,48 @@ Let Pc s1 c s2 : Prop := ∀ s1', estate_sim s1 s1' → ∃ s2', - estate_sim s2 s2' ∧ psem.sem p tt s1' c s2'. + estate_sim s2 s2' ∧ sem p ev s1' c s2'. Let Pi_r s1 i s2 : Prop := ∀ s1', estate_sim s1 s1' → ∃ s2', - estate_sim s2 s2' ∧ psem.sem_i p tt s1' i s2'. + estate_sim s2 s2' ∧ sem_i p ev s1' i s2'. Let Pi s1 i s2 : Prop := ∀ s1', estate_sim s1 s1' → ∃ s2', - estate_sim s2 s2' ∧ psem.sem_I p tt s1' i s2'. + estate_sim s2 s2' ∧ sem_I p ev s1' i s2'. Let Pfor x ws s1 c s2 : Prop := ∀ s1', estate_sim s1 s1' → ∃ s2', - estate_sim s2 s2' ∧ psem.sem_for p tt x ws s1' c s2'. + estate_sim s2 s2' ∧ sem_for p ev x ws s1' c s2'. -Let Pfun := psem.sem_call p tt. +Let Pfun := sem_call (wsw:= withsubword) p ev. Lemma psem_call scs m fn va scs' m' vr : - sem.sem_call p scs m fn va scs' m' vr → - psem.sem_call p tt scs m fn va scs' m' vr. + + (forall scs1 scs2 mem1 mem2 o ves vs, + exec_syscall (wsw:= nosubword) scs1 mem1 o ves = ok (scs2, mem2, vs) -> + exec_syscall (wsw:= withsubword) scs1 mem1 o ves = ok (scs2, mem2, vs)) -> + + (forall fd scs mem s, + init_state (f_extra fd) (p_extra p) ev {| escs := scs; emem := mem; evm := Vm.init |} = ok s -> + exists2 s', + init_state (f_extra fd) (p_extra p) ev {| escs := scs; emem := mem; evm := Vm.init |} = ok s' & + estate_sim s s') -> + + (forall fd mem, finalize (wsw:= nosubword) (f_extra fd) mem = finalize (wsw:= withsubword) (f_extra fd) mem) -> + + sem_call (wsw:= nosubword) p ev scs m fn va scs' m' vr → + sem_call (wsw:= withsubword) p ev scs m fn va scs' m' vr. Proof. +move=> hsyscall hinitstate hfinal. apply: - (sem.sem_call_Ind + (sem_call_Ind (Pc := Pc) (Pi_r := Pi_r) (Pi := Pi) @@ -294,7 +256,7 @@ apply: case: (write_lval_sim hss'1 hw) => s2' [hss'2 hw']. exists s2'; split; first exact: hss'2. by econstructor; eauto. -- move => s1 s2 tg op xs es; rewrite /sem.sem_sopn; t_xrbindP => vr va /sem_pexprs_sim hva hvr /write_lvals_sim hw s1' hss'1. +- move => s1 s2 tg op xs es; rewrite /sem_sopn; t_xrbindP => vr va /sem_pexprs_sim hva hvr /write_lvals_sim hw s1' hss'1. case: (hw _ hss'1) => s2' [hss'2 hw']; exists s2'; split; first exact: hss'2. econstructor; eauto. by rewrite /sem_sopn (hva) //= hvr. @@ -302,7 +264,9 @@ apply: have hes' := sem_pexprs_sim hss'1 hes. have /= hss':= estate_sim_scs scs1 (estate_sim_mem m1 hss'1). have [s2' [??]]:= write_lvals_sim hss' hw. - by exists s2'; split => //; econstructor; eauto; case: hss'1 => <- <-. + exists s2'; split => //. + econstructor; eauto. + by case: hss'1 => <- <- ?; apply hsyscall. - move => s1 s2 e th el /sem_pexpr_sim he _ ih s1' hss'1. case: (ih _ hss'1) => s2' [hss'2 hth]. exists s2'; split; first exact hss'2. @@ -338,16 +302,45 @@ apply: exists s2'; split; first exact: hss'2. econstructor; eauto. by apply: hargs; split. -move => scs1 m scs2 m2 fn fd va va' s1 vm2 vr vr' hfn htyin. -move=> /write_vars_sim -/(_ {| escs := scs1; emem := m |} (And3 erefl erefl vmap0_sim)). -case => s1' [hss'1 hargs] _ /(_ _ hss'1) [[scs2' m2' vm2']] [] [] /= <- <- {scs2' m2'} hvm ih. -rewrite (mapM_ext (λ (x : var_i) _, get_var_sim hvm x)) => hres htyout. -by econstructor; eauto. +move => scs1 m scs2 m2 fn fd va va' s0 s1 s2 vr vr' hfn htyin /hinitstate [s0' hinit hsim]. +move=> /(write_vars_sim hsim) [s1' [hss'1 hargs]]. +move=> _ /(_ _ hss'1) [[scs2' m2' vm2']] [] [] /= <- <- {scs2' m2'} hvm ih. +rewrite (mapM_ext (λ (x : var_i) _, get_var_sim hvm x)) hfinal => hres htyout -> ->. +econstructor; eauto. Qed. -Lemma sem_call_stack_stable (fn: funname) (scs scs': _) (m m': _) (vs vs': values) : - sem.sem_call p scs m fn vs scs' m' vs' → - stack_stable m m'. -Proof. move=> h; apply (sem_call_stack_stable_uprog (psem_call h)). Qed. - End PROOF. + +Section INSTANCE. + +Context + {asm_op syscall_state : Type} + {ep : EstateParams syscall_state} + {spp : SemPexprParams} + {sip : SemInstrParams asm_op syscall_state}. + +Lemma psem_call_u (p:uprog) scs m fn va scs' m' vr : + sem_call (wsw:= nosubword) p tt scs m fn va scs' m' vr → + sem_call (wsw:= withsubword) p tt scs m fn va scs' m' vr. +Proof. + apply (psem_call (sCP := fun wsw => sCP_unit (wsw := wsw))) => //=. + move=> _ ??? [<-]; eexists; eauto. + by split => //= x; rewrite !Vm.initP. +Qed. + +Lemma psem_call_s (p:sprog) ev scs m fn va scs' m' vr : + sem_call (wsw:= nosubword) p ev scs m fn va scs' m' vr → + sem_call (wsw:= withsubword) p ev scs m fn va scs' m' vr. +Proof. + apply (psem_call (sCP := fun wsw => sCP_stack (wsw := wsw))) => //=. + clear. + move=> fd scs mem s. + rewrite /init_stk_state; t_xrbindP => mem' -> hw. + have hsim : estate_sim {| escs := scs; emem := mem'; evm := Vm.init |} + {| escs := scs; emem := mem'; evm := Vm.init |}. + + by split => //= ?; rewrite !Vm.initP. + have [s' [hsim' hw']] := write_vars_sim hsim hw. + by exists s'. +Qed. + +End INSTANCE. diff --git a/proofs/lang/sem.v b/proofs/lang/sem.v deleted file mode 100644 index 2ee605a11..000000000 --- a/proofs/lang/sem.v +++ /dev/null @@ -1,620 +0,0 @@ -(* * Syntax and semantics of the Jasmin source language *) - -(* ** Imports and settings *) -From mathcomp Require Import all_ssreflect all_algebra. -From mathcomp Require Import word_ssrZ. -Require Import Psatz xseq. -Require Export array type expr gen_map low_memory warray_ sem_type sem_op_typed values. -Require Export - flag_combination - sem_params. -Import Utf8. - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - -(* ** Variable map - * -------------------------------------------------------------------- *) - -Notation vmap := (Fv.t (fun t => exec (sem_t t))). - -Definition undef_addr t := - match t return exec (sem_t t) with - | sbool | sint | sword _ => undef_error - | sarr n => ok (WArray.empty n) - end. - -Definition vmap0 : vmap := - @Fv.empty (fun t => exec (sem_t t)) (fun x => undef_addr x.(vtype)). - -Definition on_vu t r (fv: t -> r) (fu:exec r) (v:exec t) : exec r := - match v with - | Ok v => ok (fv v) - | Error ErrAddrUndef => fu - | Error e => Error e - end. - -Lemma on_vuP T R (fv: T -> R) (fu: exec R) (v:exec T) r P: - (forall t, v = ok t -> fv t = r -> P) -> - (v = undef_error -> fu = ok r -> P) -> - on_vu fv fu v = ok r -> P. -Proof. by case: v => [a | []] Hfv Hfu //=;[case; apply: Hfv | apply Hfu]. Qed. - -(* An access to a undefined value, leads to an error *) -Definition get_var (m:vmap) x := - on_vu (@to_val (vtype x)) undef_error (m.[x]%vmap). - -(* Assigning undefined value is allowed only for bool *) -Definition set_var (m:vmap) x v : exec vmap := - on_vu (fun v => m.[x<-ok v]%vmap) - (if is_sbool x.(vtype) then ok m.[x<-undef_addr x.(vtype)]%vmap - else type_error) - (of_val (vtype x) v). - -Lemma set_varP (m m':vmap) x v P : - (forall t, of_val (vtype x) v = ok t -> m.[x <- ok t]%vmap = m' -> P) -> - ( is_sbool x.(vtype) -> of_val (vtype x) v = undef_error -> - m.[x<-undef_addr x.(vtype)]%vmap = m' -> P) -> - set_var m x v = ok m' -> P. -Proof. - move=> H1 H2;apply on_vuP => //. - by case:ifPn => // hb herr []; apply : H2. -Qed. - -(* ** Parameter expressions - * -------------------------------------------------------------------- *) - -Definition sem_sop1 (o: sop1) (v: value) : exec value := - let t := type_of_op1 o in - Let x := of_val _ v in - ok (to_val (sem_sop1_typed o x)). - -Lemma sem_sop1I y x f: - sem_sop1 f x = ok y → - exists2 w : sem_t (type_of_op1 f).1, - of_val _ x = ok w & - y = to_val (sem_sop1_typed f w). -Proof. by rewrite /sem_sop1; t_xrbindP => w ok_w <-; eauto. Qed. - -Definition sem_sop2 (o: sop2) (v1 v2: value) : exec value := - let t := type_of_op2 o in - Let x1 := of_val _ v1 in - Let x2 := of_val _ v2 in - Let r := sem_sop2_typed o x1 x2 in - ok (to_val r). - -Lemma sem_sop2I v v1 v2 f: - sem_sop2 f v1 v2 = ok v → - ∃ (w1 : sem_t (type_of_op2 f).1.1) (w2 : sem_t (type_of_op2 f).1.2) - (w3: sem_t (type_of_op2 f).2), - [/\ of_val _ v1 = ok w1, - of_val _ v2 = ok w2, - sem_sop2_typed f w1 w2 = ok w3 & - v = to_val w3]. -Proof. - by rewrite /sem_sop2; t_xrbindP => w1 ok_w1 w2 ok_w2 w3 ok_w3 <- {v}; exists w1, w2, w3. -Qed. - -Definition sem_opN - {cfcd : FlagCombinationParams} (op: opN) (vs: values) : exec value := - Let w := app_sopn _ (sem_opN_typed op) vs in - ok (to_val w). - -Record estate - {syscall_state : Type} - {ep : EstateParams syscall_state} := Estate - { - escs : syscall_state; - emem : mem; - evm : vmap - }. - -Arguments Estate {syscall_state}%type_scope {ep} _ _ _. - -Definition get_global_value (gd: glob_decls) (g: var) : option glob_value := - assoc gd g. - -Definition gv2val (gd:glob_value) := - match gd with - | Gword ws w => Vword w - | Garr p a => Varr a - end. - -Definition get_global gd g : exec value := - if get_global_value gd g is Some ga then - let v := gv2val ga in - if type_of_val v == vtype g then ok v - else type_error - else type_error. - -Lemma get_globalI gd g v : - get_global gd g = ok v → - exists gv : glob_value, [/\ get_global_value gd g = Some gv, v = gv2val gv & type_of_val v = vtype g]. -Proof. - rewrite /get_global; case: get_global_value => // gv. - by case:eqP => // <- [<-];exists gv. -Qed. - -Definition get_gvar (gd: glob_decls) (vm: vmap) (x:gvar) := - if is_lvar x then get_var vm x.(gv) - else get_global gd x.(gv). - -Definition on_arr_var A (v:exec value) (f:forall n, WArray.array n -> exec A) := - Let v := v in - match v with - | Varr n t => f n t - | _ => type_error - end. - -Notation "'Let' ( n , t ) ':=' s '.[' v ']' 'in' body" := - (@on_arr_var _ (get_var s.(evm) v) (fun n (t:WArray.array n) => body)) (at level 25, s at level 0). - -Notation "'Let' ( n , t ) ':=' gd ',' s '.[' v ']' 'in' body" := - (@on_arr_var _ (get_gvar gd s.(evm) v) (fun n (t:WArray.array n) => body)) (at level 25, gd at level 0, s at level 0). - -Lemma type_of_get_var x vm v : - get_var vm x = ok v -> - type_of_val v = x.(vtype). -Proof. by rewrite /get_var; apply : on_vuP => // t _ <-; apply type_of_to_val. Qed. - -Lemma on_arr_varP {syscall_state : Type} {ep : EstateParams syscall_state} - A (f : forall n, WArray.array n -> exec A) v s x P : - (forall n t, vtype x = sarr n -> - get_var (evm s) x = ok (@Varr n t) -> - f n t = ok v -> P) -> - on_arr_var (get_var (evm s) x) f = ok v -> P. -Proof. - rewrite /on_arr_var=> H;apply: rbindP => vx hx. - have h := type_of_get_var hx; case: vx h hx => // len t h. - by apply: H;rewrite -h. -Qed. - -Lemma type_of_get_global gd g v : - get_global gd g = ok v -> type_of_val v = vtype g. -Proof. by move=> /get_globalI [?[]]. Qed. - -Lemma type_of_get_gvar x gd vm v : - get_gvar gd vm x = ok v -> - type_of_val v = vtype x.(gv). -Proof. - rewrite /get_gvar;case:ifP => ?. - + by apply type_of_get_var. - by apply type_of_get_global. -Qed. - -Lemma on_arr_gvarP A (f : forall n, WArray.array n -> exec A) v gd s x P: - (forall n t, vtype x.(gv) = sarr n -> - get_gvar gd s x = ok (@Varr n t) -> - f n t = ok v -> P) -> - on_arr_var (get_gvar gd s x) f = ok v -> P. -Proof. - rewrite /on_arr_var=> H;apply: rbindP => vx hx. - have h := type_of_get_gvar hx; case: vx h hx => // len t h. - by apply: H;rewrite -h. -Qed. - -Section SEM_PEXPR. - -Context - {asm_op syscall_state : Type} - {ep : EstateParams syscall_state} - {spp : SemPexprParams} - (gd : glob_decls). - -Fixpoint sem_pexpr (s:estate) (e : pexpr) : exec value := - match e with - | Pconst z => ok (Vint z) - | Pbool b => ok (Vbool b) - | Parr_init n => ok (Varr (WArray.empty n)) - | Pvar v => get_gvar gd s.(evm) v - | Pget aa ws x e => - Let (n, t) := gd, s.[x] in - Let i := sem_pexpr s e >>= to_int in - Let w := WArray.get aa ws t i in - ok (Vword w) - | Psub aa ws len x e => - Let (n, t) := gd, s.[x] in - Let i := sem_pexpr s e >>= to_int in - Let t' := WArray.get_sub aa ws len t i in - ok (Varr t') - | Pload sz x e => - Let w1 := get_var s.(evm) x >>= to_pointer in - Let w2 := sem_pexpr s e >>= to_pointer in - Let w := read s.(emem) (w1 + w2)%R sz in - ok (@to_val (sword sz) w) - | Papp1 o e1 => - Let v1 := sem_pexpr s e1 in - sem_sop1 o v1 - | Papp2 o e1 e2 => - Let v1 := sem_pexpr s e1 in - Let v2 := sem_pexpr s e2 in - sem_sop2 o v1 v2 - | PappN op es => - Let vs := mapM (sem_pexpr s) es in - sem_opN op vs - | Pif t e e1 e2 => - Let b := sem_pexpr s e >>= to_bool in - Let v1 := sem_pexpr s e1 >>= truncate_val t in - Let v2 := sem_pexpr s e2 >>= truncate_val t in - ok (if b then v1 else v2) - end. - -Definition sem_pexprs s := mapM (sem_pexpr s). - -Definition write_var (x:var_i) (v:value) (s:estate) : exec estate := - Let vm := set_var s.(evm) x v in - ok ({| escs := s.(escs); emem := s.(emem); evm := vm |}). - -Definition write_vars xs vs s := - fold2 ErrType write_var xs vs s. - -Definition write_none (s:estate) ty v := - on_vu (fun v => s) (if is_sbool ty then ok s else type_error) - (of_val ty v). - -Definition write_lval (l:lval) (v:value) (s:estate) : exec estate := - match l with - | Lnone _ ty => write_none s ty v - | Lvar x => write_var x v s - | Lmem sz x e => - Let vx := get_var (evm s) x >>= to_pointer in - Let ve := sem_pexpr s e >>= to_pointer in - let p := (vx + ve)%R in (* should we add the size of value, i.e vx + sz * se *) - Let w := to_word sz v in - Let m := write s.(emem) p w in - ok {| escs := s.(escs); emem := m; evm := s.(evm) |} - | Laset aa ws x i => - Let (n,t) := s.[x] in - Let i := sem_pexpr s i >>= to_int in - Let v := to_word ws v in - Let t := WArray.set t aa i v in - write_var x (@to_val (sarr n) t) s - | Lasub aa ws len x i => - Let (n,t) := s.[x] in - Let i := sem_pexpr s i >>= to_int in - Let t' := to_arr (Z.to_pos (arr_size ws len)) v in - Let t := @WArray.set_sub n aa ws len t i t' in - write_var x (@to_val (sarr n) t) s - end. - -Definition write_lvals (s:estate) xs vs := - fold2 ErrType write_lval xs vs s. - -End SEM_PEXPR. - -Section EXEC_SYSCALL. - -Context - {syscall_state : Type} - {scs : syscall_sem syscall_state} . - -Definition exec_getrandom (scs : syscall_state) len vs := - Let _ := - match vs with - | [:: v] => to_arr len v - | _ => type_error - end in - let sd := get_random scs (Zpos len) in - Let t := WArray.fill len sd.2 in - ok (sd.1, [::Varr t]). - -Definition exec_syscall - {pd : PointerData} - (scs : syscall_state_t) - (m : mem) - (o : syscall_t) - (vs : values) : - exec (syscall_state_t * mem * values) := - match o with - | RandomBytes len => - Let sv := exec_getrandom scs len vs in - ok (sv.1, m, sv.2) - end. - -End EXEC_SYSCALL. - -Section EXEC_ASM. - -Context - {asm_op syscall_state : Type} - {ep : EstateParams syscall_state} - {spp : SemPexprParams} - {asmop : asmOp asm_op}. - -Definition exec_sopn (o:sopn) (vs:values) : exec values := - let semi := sopn_sem o in - Let t := app_sopn _ semi vs in - ok (list_ltuple t). - -Lemma sopn_toutP o vs vs' : exec_sopn o vs = ok vs' -> - List.map type_of_val vs' = sopn_tout o. -Proof. - rewrite /exec_sopn /sopn_tout /sopn_sem. - t_xrbindP => p _ <-;apply type_of_val_ltuple. -Qed. - -Definition sem_sopn gd o m lvs args := - sem_pexprs gd m args >>= exec_sopn o >>= write_lvals gd m lvs. - -End EXEC_ASM. - -Section SEM. - -Context - {asm_op syscall_state : Type} - {ep : EstateParams syscall_state} - {spp : SemPexprParams} - {sip : SemInstrParams asm_op syscall_state} - (P : uprog). - -Notation gd := (p_globs P). - -Inductive sem : estate -> cmd -> estate -> Prop := -| Eskip s : - sem s [::] s - -| Eseq s1 s2 s3 i c : - sem_I s1 i s2 -> sem s2 c s3 -> sem s1 (i::c) s3 - -with sem_I : estate -> instr -> estate -> Prop := -| EmkI ii i s1 s2: - sem_i s1 i s2 -> - sem_I s1 (MkI ii i) s2 - -with sem_i : estate -> instr_r -> estate -> Prop := -| Eassgn s1 s2 (x:lval) tag ty e v v': - sem_pexpr gd s1 e = ok v -> - truncate_val ty v = ok v' → - write_lval gd x v' s1 = ok s2 -> - sem_i s1 (Cassgn x tag ty e) s2 - -| Eopn s1 s2 t o xs es: - sem_sopn gd o s1 xs es = ok s2 -> - sem_i s1 (Copn xs t o es) s2 - -| Esyscall s1 scs m s2 xs o es ves vs: - sem_pexprs gd s1 es = ok ves → - exec_syscall s1.(escs) s1.(emem) o ves = ok (scs, m, vs) → - write_lvals gd {| escs := scs; emem := m; evm := s1.(evm) |} xs vs = ok s2 → - sem_i s1 (Csyscall xs o es) s2 - -| Eif_true s1 s2 e c1 c2 : - sem_pexpr gd s1 e = ok (Vbool true) -> - sem s1 c1 s2 -> - sem_i s1 (Cif e c1 c2) s2 - -| Eif_false s1 s2 e c1 c2 : - sem_pexpr gd s1 e = ok (Vbool false) -> - sem s1 c2 s2 -> - sem_i s1 (Cif e c1 c2) s2 - -| Ewhile_true s1 s2 s3 s4 a c e c' : - sem s1 c s2 -> - sem_pexpr gd s2 e = ok (Vbool true) -> - sem s2 c' s3 -> - sem_i s3 (Cwhile a c e c') s4 -> - sem_i s1 (Cwhile a c e c') s4 - -| Ewhile_false s1 s2 a c e c' : - sem s1 c s2 -> - sem_pexpr gd s2 e = ok (Vbool false) -> - sem_i s1 (Cwhile a c e c') s2 - -| Efor s1 s2 (i:var_i) d lo hi c vlo vhi : - sem_pexpr gd s1 lo = ok (Vint vlo) -> - sem_pexpr gd s1 hi = ok (Vint vhi) -> - sem_for i (wrange d vlo vhi) s1 c s2 -> - sem_i s1 (Cfor i (d, lo, hi) c) s2 - -| Ecall s1 scs2 m2 s2 ii xs f args vargs vs : - sem_pexprs gd s1 args = ok vargs -> - sem_call s1.(escs) s1.(emem) f vargs scs2 m2 vs -> - write_lvals gd {|escs := scs2; emem:= m2; evm := s1.(evm) |} xs vs = ok s2 -> - sem_i s1 (Ccall ii xs f args) s2 - -with sem_for : var_i -> seq Z -> estate -> cmd -> estate -> Prop := -| EForDone s i c : - sem_for i [::] s c s - -| EForOne s1 s1' s2 s3 i w ws c : - write_var i (Vint w) s1 = ok s1' -> - sem s1' c s2 -> - sem_for i ws s2 c s3 -> - sem_for i (w :: ws) s1 c s3 - -with sem_call : syscall_state_t -> mem -> funname -> seq value -> syscall_state_t -> mem -> seq value -> Prop := -| EcallRun scs1 m1 scs2 m2 fn f vargs vargs' s1 vm2 vres vres' : - get_fundef (p_funcs P) fn = Some f -> - mapM2 ErrType truncate_val f.(f_tyin) vargs' = ok vargs -> - write_vars f.(f_params) vargs (Estate scs1 m1 vmap0) = ok s1 -> - sem s1 f.(f_body) (Estate scs2 m2 vm2) -> - mapM (fun (x:var_i) => get_var vm2 x) f.(f_res) = ok vres -> - mapM2 ErrType truncate_val f.(f_tyout) vres = ok vres' -> - sem_call scs1 m1 fn vargs' scs2 m2 vres'. - -(* We define a custom induction principle for program semantics. *) -Section SEM_IND. - - Variables - (Pc : estate -> cmd -> estate -> Prop) - (Pi_r : estate -> instr_r -> estate -> Prop) - (Pi : estate -> instr -> estate -> Prop) - (Pfor : var_i -> seq Z -> estate -> cmd -> estate -> Prop) - (Pfun : syscall_state_t -> mem -> funname -> seq value -> syscall_state_t -> mem -> seq value -> Prop). - - Definition sem_Ind_nil : Prop := - forall s : estate, Pc s [::] s. - - Definition sem_Ind_cons : Prop := - forall (s1 s2 s3 : estate) (i : instr) (c : cmd), - sem_I s1 i s2 -> Pi s1 i s2 -> sem s2 c s3 -> Pc s2 c s3 -> Pc s1 (i :: c) s3. - - Hypotheses - (Hnil: sem_Ind_nil) - (Hcons: sem_Ind_cons) - . - - Definition sem_Ind_mkI : Prop := - forall (ii : instr_info) (i : instr_r) (s1 s2 : estate), - sem_i s1 i s2 -> Pi_r s1 i s2 -> Pi s1 (MkI ii i) s2. - - Hypothesis HmkI : sem_Ind_mkI. - - Definition sem_Ind_assgn : Prop := - forall (s1 s2 : estate) (x : lval) (tag : assgn_tag) ty (e : pexpr) v v', - sem_pexpr gd s1 e = ok v -> - truncate_val ty v = ok v' → - write_lval gd x v' s1 = Ok error s2 -> - Pi_r s1 (Cassgn x tag ty e) s2. - - Definition sem_Ind_opn : Prop := - forall (s1 s2 : estate) t (o : sopn) (xs : lvals) (es : pexprs), - sem_sopn gd o s1 xs es = Ok error s2 -> - Pi_r s1 (Copn xs t o es) s2. - - Definition sem_Ind_syscall : Prop := - forall s1 scs m s2 xs o es ves vs, - sem_pexprs gd s1 es = ok ves → - exec_syscall s1.(escs) s1.(emem) o ves = ok (scs, m, vs) → - write_lvals gd {| escs := scs; emem := m; evm := s1.(evm) |} xs vs = ok s2 → - Pi_r s1 (Csyscall xs o es) s2. - - Definition sem_Ind_if_true : Prop := - forall (s1 s2 : estate) (e : pexpr) (c1 c2 : cmd), - sem_pexpr gd s1 e = ok (Vbool true) -> - sem s1 c1 s2 -> Pc s1 c1 s2 -> Pi_r s1 (Cif e c1 c2) s2. - - Definition sem_Ind_if_false : Prop := - forall (s1 s2 : estate) (e : pexpr) (c1 c2 : cmd), - sem_pexpr gd s1 e = ok (Vbool false) -> - sem s1 c2 s2 -> Pc s1 c2 s2 -> Pi_r s1 (Cif e c1 c2) s2. - - Definition sem_Ind_while_true : Prop := - forall (s1 s2 s3 s4 : estate) a (c : cmd) (e : pexpr) (c' : cmd), - sem s1 c s2 -> Pc s1 c s2 -> - sem_pexpr gd s2 e = ok (Vbool true) -> - sem s2 c' s3 -> Pc s2 c' s3 -> - sem_i s3 (Cwhile a c e c') s4 -> Pi_r s3 (Cwhile a c e c') s4 -> Pi_r s1 (Cwhile a c e c') s4. - - Definition sem_Ind_while_false : Prop := - forall (s1 s2 : estate) a (c : cmd) (e : pexpr) (c' : cmd), - sem s1 c s2 -> Pc s1 c s2 -> - sem_pexpr gd s2 e = ok (Vbool false) -> - Pi_r s1 (Cwhile a c e c') s2. - - Hypotheses - (Hasgn: sem_Ind_assgn) - (Hopn: sem_Ind_opn) - (Hsyscall: sem_Ind_syscall) - (Hif_true: sem_Ind_if_true) - (Hif_false: sem_Ind_if_false) - (Hwhile_true: sem_Ind_while_true) - (Hwhile_false: sem_Ind_while_false) - . - - Definition sem_Ind_for : Prop := - forall (s1 s2 : estate) (i : var_i) (d : dir) (lo hi : pexpr) (c : cmd) (vlo vhi : Z), - sem_pexpr gd s1 lo = ok (Vint vlo) -> - sem_pexpr gd s1 hi = ok (Vint vhi) -> - sem_for i (wrange d vlo vhi) s1 c s2 -> - Pfor i (wrange d vlo vhi) s1 c s2 -> Pi_r s1 (Cfor i (d, lo, hi) c) s2. - - Definition sem_Ind_for_nil : Prop := - forall (s : estate) (i : var_i) (c : cmd), - Pfor i [::] s c s. - - Definition sem_Ind_for_cons : Prop := - forall (s1 s1' s2 s3 : estate) (i : var_i) (w : Z) (ws : seq Z) (c : cmd), - write_var i w s1 = Ok error s1' -> - sem s1' c s2 -> Pc s1' c s2 -> - sem_for i ws s2 c s3 -> Pfor i ws s2 c s3 -> Pfor i (w :: ws) s1 c s3. - - Hypotheses - (Hfor: sem_Ind_for) - (Hfor_nil: sem_Ind_for_nil) - (Hfor_cons: sem_Ind_for_cons) - . - - Definition sem_Ind_call : Prop := - forall (s1 : estate) (scs2 : syscall_state_t) (m2 : mem) (s2 : estate) - (ii : inline_info) (xs : lvals) - (fn : funname) (args : pexprs) (vargs vs : seq value), - sem_pexprs gd s1 args = Ok error vargs -> - sem_call (escs s1) (emem s1) fn vargs scs2 m2 vs -> Pfun (escs s1) (emem s1) fn vargs scs2 m2 vs -> - write_lvals gd {| escs := scs2; emem := m2; evm := evm s1 |} xs vs = Ok error s2 -> - Pi_r s1 (Ccall ii xs fn args) s2. - - Definition sem_Ind_proc : Prop := - forall (scs1 : syscall_state_t) (m1 : mem) (scs2 : syscall_state_t) (m2 : mem) (fn:funname) (f : fundef) (vargs vargs': seq value) - (s1 : estate) (vm2 : vmap) (vres vres': seq value), - get_fundef (p_funcs P) fn = Some f -> - mapM2 ErrType truncate_val f.(f_tyin) vargs' = ok vargs -> - write_vars (f_params f) vargs {| escs := scs1; emem := m1; evm := vmap0 |} = ok s1 -> - sem s1 (f_body f) {| escs := scs2; emem := m2; evm := vm2 |} -> - Pc s1 (f_body f) {| escs := scs2; emem := m2; evm := vm2 |} -> - mapM (fun x : var_i => get_var vm2 x) (f_res f) = ok vres -> - mapM2 ErrType truncate_val f.(f_tyout) vres = ok vres' -> - Pfun scs1 m1 fn vargs' scs2 m2 vres'. - - Hypotheses - (Hcall: sem_Ind_call) - (Hproc: sem_Ind_proc) - . - - Fixpoint sem_Ind (e : estate) (l : cmd) (e0 : estate) (s : sem e l e0) {struct s} : - Pc e l e0 := - match s in (sem e1 l0 e2) return (Pc e1 l0 e2) with - | Eskip s0 => Hnil s0 - | @Eseq s1 s2 s3 i c s0 s4 => - @Hcons s1 s2 s3 i c s0 (@sem_I_Ind s1 i s2 s0) s4 (@sem_Ind s2 c s3 s4) - end - - with sem_i_Ind (e : estate) (i : instr_r) (e0 : estate) (s : sem_i e i e0) {struct s} : - Pi_r e i e0 := - match s in (sem_i e1 i0 e2) return (Pi_r e1 i0 e2) with - | @Eassgn s1 s2 x tag ty e1 v v' h1 h2 h3 => @Hasgn s1 s2 x tag ty e1 v v' h1 h2 h3 - | @Eopn s1 s2 t o xs es e1 => @Hopn s1 s2 t o xs es e1 - | @Esyscall s1 scs m s2 xs o es ves vs h1 h2 h3 => @Hsyscall s1 scs m s2 xs o es ves vs h1 h2 h3 - | @Eif_true s1 s2 e1 c1 c2 e2 s0 => - @Hif_true s1 s2 e1 c1 c2 e2 s0 (@sem_Ind s1 c1 s2 s0) - | @Eif_false s1 s2 e1 c1 c2 e2 s0 => - @Hif_false s1 s2 e1 c1 c2 e2 s0 (@sem_Ind s1 c2 s2 s0) - | @Ewhile_true s1 s2 s3 s4 a c e1 c' h1 h2 h3 h4 => - @Hwhile_true s1 s2 s3 s4 a c e1 c' h1 (@sem_Ind s1 c s2 h1) h2 h3 (@sem_Ind s2 c' s3 h3) - h4 (@sem_i_Ind s3 (Cwhile a c e1 c') s4 h4) - | @Ewhile_false s1 s2 a c e1 c' s0 e2 => - @Hwhile_false s1 s2 a c e1 c' s0 (@sem_Ind s1 c s2 s0) e2 - | @Efor s1 s2 i0 d lo hi c vlo vhi e1 e2 s0 => - @Hfor s1 s2 i0 d lo hi c vlo vhi e1 e2 s0 - (@sem_for_Ind i0 (wrange d vlo vhi) s1 c s2 s0) - | @Ecall s1 scs2 m2 s2 ii xs f13 args vargs vs e2 s0 e3 => - @Hcall s1 scs2 m2 s2 ii xs f13 args vargs vs e2 s0 - (@sem_call_Ind (escs s1) (emem s1) f13 vargs scs2 m2 vs s0) e3 - end - - with sem_I_Ind (e : estate) (i : instr) (e0 : estate) (s : sem_I e i e0) {struct s} : - Pi e i e0 := - match s in (sem_I e1 i0 e2) return (Pi e1 i0 e2) with - | @EmkI ii i0 s1 s2 s0 => @HmkI ii i0 s1 s2 s0 (@sem_i_Ind s1 i0 s2 s0) - end - - with sem_for_Ind (v : var_i) (l : seq Z) (e : estate) (l0 : cmd) (e0 : estate) - (s : sem_for v l e l0 e0) {struct s} : Pfor v l e l0 e0 := - match s in (sem_for v0 l1 e1 l2 e2) return (Pfor v0 l1 e1 l2 e2) with - | EForDone s0 i c => Hfor_nil s0 i c - | @EForOne s1 s1' s2 s3 i w ws c e1 s0 s4 => - @Hfor_cons s1 s1' s2 s3 i w ws c e1 s0 (@sem_Ind s1' c s2 s0) - s4 (@sem_for_Ind i ws s2 c s3 s4) - end - - with sem_call_Ind (scs : syscall_state_t) (m : mem) (f13 : funname) (l : seq value) (scs0 : syscall_state_t) (m0 : mem) - (l0 : seq value) (s : sem_call scs m f13 l scs0 m0 l0) {struct s} : Pfun scs m f13 l scs0 m0 l0 := - match s with - | @EcallRun scs1 m1 scs2 m2 fn f vargs vargs' s1 vm2 vres vres' Hget Hctin Hw Hsem Hvres Hctout => - @Hproc scs1 m1 scs2 m2 fn f vargs vargs' s1 vm2 vres vres' Hget Hctin Hw Hsem (sem_Ind Hsem) Hvres Hctout - end. - -End SEM_IND. - -End SEM. diff --git a/proofs/lang/sem_one_varmap.v b/proofs/lang/sem_one_varmap.v index b97c52edf..2eb02604e 100644 --- a/proofs/lang/sem_one_varmap.v +++ b/proofs/lang/sem_one_varmap.v @@ -13,8 +13,6 @@ Unset Printing Implicit Defensive. Local Unset Elimination Schemes. -Local Open Scope vmap_scope. - (** Semantics of programs in which there is a single scope for local variables. Function arguments and returns are passed by name: the caller puts the arguments in the right variables and read them from the right variables. @@ -33,22 +31,25 @@ The semantics also ensures some properties: The semantic predicates are indexed by a set of variables which is *precisely* the set of variables that are written during the execution. *) -Definition kill_var (x: var) (vm: vmap) : vmap := - vm.[x <- pundef_addr (vtype x)]. +#[local] Existing Instance withsubword. + +Definition kill_var (x: var) (vm: Vm.t) : Vm.t := + vm.[x <- undef_addr (vtype x)]. Notation kill_vars := (Sv.fold kill_var). -Definition vm_after_syscall {ovm_i : one_varmap_info} (vm:vmap) := +Definition vm_after_syscall {ovm_i : one_varmap_info} (vm:Vm.t) := kill_vars syscall_kill vm. Lemma kill_varE vm y x : - ((kill_var x vm).[y] = if x == y then pundef_addr (vtype y) else vm.[y])%vmap. + (kill_var x vm).[y] = if x == y then undef_addr (vtype y) else vm.[y]. Proof. - by rewrite /kill_var Fv.setP; case: eqP => // ?; subst y. + rewrite /kill_var Vm.setP; case: eqP => // ?; subst y. + by rewrite vm_truncate_val_undef. Qed. Lemma kill_varsE vm xs x : - ((kill_vars xs vm).[x] = if Sv.mem x xs then pundef_addr (vtype x) else vm.[x])%vmap. + (kill_vars xs vm).[x] = if Sv.mem x xs then undef_addr (vtype x) else vm.[x]. Proof. rewrite Sv_elems_eq Sv.fold_spec. elim: (Sv.elements xs) vm => // {xs} f xs ih vm /=. @@ -57,14 +58,10 @@ Proof. Qed. Lemma kill_vars_uincl vm xs : - wf_vm vm -> - vm_uincl (kill_vars xs vm) vm. + kill_vars xs vm <=1 vm. Proof. - move => hwf x; rewrite kill_varsE. - case: ifP => // _. - case: vm.[x] (hwf x)=> // [v | e]. - + by move=> _; apply eval_uincl_undef. - case: e => //; case: (vtype x) => //. + move => x; rewrite kill_varsE. + case: ifP => // _; apply/subtype_value_uincl_undef/subtype_undef_get. Qed. Section SEM. @@ -98,10 +95,10 @@ Definition ra_valid fd (ii:instr_info) (k: Sv.t) (x: var) : bool := Definition ra_undef_none (ss: saved_stack) (x: var) := Sv.union (Sv.add x vflags) (savedstackreg ss). -Definition ra_undef_vm_none (ss: saved_stack) (x: var) vm : vmap := +Definition ra_undef_vm_none (ss: saved_stack) (x: var) vm : Vm.t := kill_vars (ra_undef_none ss x) vm. -Definition ra_undef_vm fd vm (x: var) : vmap := +Definition ra_undef_vm fd vm (x: var) : Vm.t := kill_vars (ra_undef fd x) vm. Definition saved_stack_valid fd (k: Sv.t) : bool := @@ -113,16 +110,16 @@ Definition top_stack_aligned fd st : bool := (fd.(f_extra).(sf_return_address) == RAnone) || is_align (top_stack st.(emem)) fd.(f_extra).(sf_align). -Definition set_RSP m vm : vmap := - vm.[vrsp <- ok (pword_of_word (top_stack m))]. -#[global] Arguments set_RSP _ _%vmap_scope. +Definition set_RSP m vm : Vm.t := + vm.[vrsp <- Vword (top_stack m)]. +#[global] Arguments set_RSP _ _%vm_scope. -Definition valid_RSP m (vm: vmap) : Prop := - vm.[vrsp] = ok (pword_of_word (top_stack m)). +Definition valid_RSP m (vm: Vm.t) : Prop := + vm.[vrsp] = Vword (top_stack m). Remark valid_set_RSP m vm : valid_RSP m (set_RSP m vm). -Proof. by rewrite /valid_RSP Fv.setP_eq. Qed. +Proof. by rewrite /valid_RSP Vm.setP_eq vm_truncate_val_eq. Qed. Inductive sem : Sv.t → estate → cmd → estate → Prop := | Eskip s : @@ -141,9 +138,9 @@ with sem_I : Sv.t → estate → instr → estate → Prop := with sem_i : instr_info → Sv.t → estate → instr_r → estate → Prop := | Eassgn ii s1 s2 (x:lval) tag ty e v v' : - sem_pexpr gd s1 e = ok v → + sem_pexpr true gd s1 e = ok v → truncate_val ty v = ok v' → - write_lval gd x v' s1 = ok s2 → + write_lval true gd x v' s1 = ok s2 → sem_i ii (vrv x) s1 (Cassgn x tag ty e) s2 | Eopn ii s1 s2 t o xs es: @@ -151,32 +148,32 @@ with sem_i : instr_info → Sv.t → estate → instr_r → estate → Prop := sem_i ii (vrvs xs) s1 (Copn xs t o es) s2 | Esyscall ii s1 scs m s2 o xs es ves vs: - mapM (get_var s1.(evm)) (syscall_sig o).(scs_vin) = ok ves -> + mapM (get_var true s1.(evm)) (syscall_sig o).(scs_vin) = ok ves -> exec_syscall (semCallParams:= sCP_stack) s1.(escs) s1.(emem) o ves = ok (scs, m, vs) → - write_lvals gd {| escs := scs; emem := m; evm := vm_after_syscall s1.(evm) |} + write_lvals true gd {| escs := scs; emem := m; evm := vm_after_syscall s1.(evm) |} (to_lvals (syscall_sig o).(scs_vout)) vs = ok s2 → sem_i ii (Sv.union syscall_kill (vrvs (to_lvals (syscall_sig o).(scs_vout)))) s1 (Csyscall xs o es) s2 | Eif_true ii k s1 s2 e c1 c2 : - sem_pexpr gd s1 e = ok (Vbool true) → + sem_pexpr true gd s1 e = ok (Vbool true) → sem k s1 c1 s2 → sem_i ii k s1 (Cif e c1 c2) s2 | Eif_false ii k s1 s2 e c1 c2 : - sem_pexpr gd s1 e = ok (Vbool false) → + sem_pexpr true gd s1 e = ok (Vbool false) → sem k s1 c2 s2 → sem_i ii k s1 (Cif e c1 c2) s2 | Ewhile_true ii k k' krec s1 s2 s3 s4 a c e c' : sem k s1 c s2 → - sem_pexpr gd s2 e = ok (Vbool true) → + sem_pexpr true gd s2 e = ok (Vbool true) → sem k' s2 c' s3 → sem_I krec s3 (MkI ii (Cwhile a c e c')) s4 → sem_i ii (Sv.union (Sv.union k k') krec) s1 (Cwhile a c e c') s4 | Ewhile_false ii k s1 s2 a c e c' : sem k s1 c s2 → - sem_pexpr gd s2 e = ok (Vbool false) → + sem_pexpr true gd s2 e = ok (Vbool false) → sem_i ii k s1 (Cwhile a c e c') s2 | Ecall ii k s1 s2 ini res f args xargs xres : @@ -186,7 +183,7 @@ with sem_i : instr_info → Sv.t → estate → instr_r → estate → Prop := sem_i ii k s1 (Ccall ini res f args) s2 with sem_call : instr_info → Sv.t → estate → funname → estate → Prop := -| EcallRun ii k s1 s2 fn f args m1 s2' res : +| EcallRun ii k s1 s2 fn f (* args *) m1 s2' (* res *) : get_fundef (p_funcs p) fn = Some f → ra_valid f ii k var_tmp → saved_stack_valid f k → @@ -199,28 +196,28 @@ with sem_call : instr_info → Sv.t → estate → funname → estate → Prop : f.(f_extra).(sf_stk_ioff) f.(f_extra).(sf_stk_extra_sz) = ok m1 → - mapM (λ x : var_i, get_var s1.(evm) x) f.(f_params) = ok args → - all2 check_ty_val f.(f_tyin) args → +(* mapM (λ x : var_i, get_var false s1.(evm) x) f.(f_params) = ok args → + all2 check_ty_val f.(f_tyin) args → *) let vm1 := ra_undef_vm f s1.(evm) var_tmp in sem k {| escs := s1.(escs); emem := m1; evm := set_RSP m1 vm1; |} f.(f_body) s2' → - mapM (λ x : var_i, get_var s2'.(evm) x) f.(f_res) = ok res → - all2 check_ty_val f.(f_tyout) res → +(* mapM (λ x : var_i, get_var false s2'.(evm) x) f.(f_res) = ok res → + all2 check_ty_val f.(f_tyout) res → *) valid_RSP s2'.(emem) s2'.(evm) → let m2 := free_stack s2'.(emem) in s2 = {| escs := s2'.(escs); emem := m2 ; evm := set_RSP m2 s2'.(evm) |} → let vm := Sv.union (ra_vm f.(f_extra) var_tmp) (saved_stack_vm f) in sem_call ii (Sv.union k vm) s1 fn s2. -Variant sem_export_call_conclusion (scs: syscall_state_t) (m: mem) (fd: sfundef) (args: values) (vm: vmap) (scs': syscall_state_t) (m': mem) (res: values) : Prop := - | SemExportCallConclusion (m1: mem) (k: Sv.t) (m2: mem) (vm2: vmap) (res': values) of +Variant sem_export_call_conclusion (scs: syscall_state_t) (m: mem) (fd: sfundef) (args: values) (vm: Vm.t) (scs': syscall_state_t) (m': mem) (res: values) : Prop := + | SemExportCallConclusion (m1: mem) (k: Sv.t) (m2: mem) (vm2: Vm.t) (res':values) of saved_stack_valid fd k & Sv.Subset (Sv.inter callee_saved (Sv.union k (Sv.union (ra_vm fd.(f_extra) var_tmp) (saved_stack_vm fd)))) (sv_of_list fst fd.(f_extra).(sf_to_save)) & alloc_stack m fd.(f_extra).(sf_align) fd.(f_extra).(sf_stk_sz) fd.(f_extra).(sf_stk_ioff) fd.(f_extra).(sf_stk_extra_sz) = ok m1 & - all2 check_ty_val fd.(f_tyin) args & +(* all2 check_ty_val fd.(f_tyin) args & *) sem k {| escs := scs; emem := m1 ; evm := set_RSP m1 (ra_undef_vm_none fd.(f_extra).(sf_save_stack) var_tmp vm) |} fd.(f_body) {| escs:= scs'; emem := m2 ; evm := vm2 |} & - mapM (λ x : var_i, get_var vm2 x) fd.(f_res) = ok res' & + mapM (λ x : var_i, get_var false vm2 x) fd.(f_res) = ok res' & List.Forall2 value_uincl res res' & - all2 check_ty_val fd.(f_tyout) res' & + (* all2 check_ty_val fd.(f_tyout) res' & *) valid_RSP m2 vm2 & m' = free_stack m2. @@ -231,19 +228,18 @@ Variant sem_export_call (gd: @extra_val_t _ progStack) (scs: syscall_state_t) ( disjoint (sv_of_list fst fd.(f_extra).(sf_to_save)) (sv_of_list v_var fd.(f_res)) & ~~ Sv.mem vrsp (sv_of_list v_var fd.(f_res)) & ∀ vm args', - wf_vm vm → - mapM (λ x : var_i, get_var vm x) fd.(f_params) = ok args' → + mapM (λ x : var_i, get_var false vm x) fd.(f_params) = ok args' → List.Forall2 value_uincl args args' → valid_RSP m vm → - vm.[vgd] = ok (pword_of_word gd) → + vm.[vgd] = Vword gd → sem_export_call_conclusion scs m fd args' vm scs' m' res. (*---------------------------------------------------*) Variant ex3_3 (A B C : Type) (P1 P2 P3: A → B → C → Prop) : Prop := Ex3_3 a b c of P1 a b c & P2 a b c & P3 a b c. -Variant ex6_14 (A B C D E F : Type) (P1 P2 P3 P4 P5 P6 P7 P8 P9 P10 P11 P12 P13 P14 : A → B → C → D → E → F → Prop) : Prop := -| Ex6_14 a b c d e f of P1 a b c d e f & P2 a b c d e f & P3 a b c d e f & P4 a b c d e f & P5 a b c d e f & P6 a b c d e f & P7 a b c d e f & P8 a b c d e f & P9 a b c d e f & P10 a b c d e f & P11 a b c d e f & P12 a b c d e f & P13 a b c d e f & P14 a b c d e f. +Variant ex4_10 (A B C D : Type) (P1 P2 P3 P4 P5 P6 P7 P8 P9 P10 : A → B → C → D → Prop) : Prop := +| Ex6_14 a b c d of P1 a b c d & P2 a b c d & P3 a b c d & P4 a b c d & P5 a b c d & P6 a b c d & P7 a b c d & P8 a b c d & P9 a b c d & P10 a b c d. (*---------------------------------------------------*) (* Small inversion principles *) @@ -269,20 +265,20 @@ Lemma sem_iE ii k s i s' : match i with | Cassgn x tag ty e => k = vrv x ∧ - exists2 v', sem_pexpr gd s e >>= truncate_val ty = ok v' & write_lval gd x v' s = ok s' + exists2 v', sem_pexpr true gd s e >>= truncate_val ty = ok v' & write_lval true gd x v' s = ok s' | Copn xs t o es => k = vrvs xs ∧ sem_sopn gd o s xs es = ok s' | Csyscall xs o es => k = Sv.union syscall_kill (vrvs (to_lvals (syscall_sig o).(scs_vout))) /\ ∃ scs m ves vs, - [/\ mapM (get_var s.(evm)) (syscall_sig o).(scs_vin) = ok ves, + [/\ mapM (get_var true s.(evm)) (syscall_sig o).(scs_vin) = ok ves, exec_syscall (semCallParams:= sCP_stack) s.(escs) s.(emem) o ves = ok (scs, m, vs) & - write_lvals gd {| escs := scs; emem := m; evm := vm_after_syscall s.(evm) |} + write_lvals true gd {| escs := scs; emem := m; evm := vm_after_syscall s.(evm) |} (to_lvals (syscall_sig o).(scs_vout)) vs = ok s'] | Cif e c1 c2 => - exists2 b, sem_pexpr gd s e = ok (Vbool b) & sem k s (if b then c1 else c2) s' + exists2 b, sem_pexpr true gd s e = ok (Vbool b) & sem k s (if b then c1 else c2) s' | Cwhile a c e c' => ∃ kc si b, - [/\ sem kc s c si, sem_pexpr gd si e = ok (Vbool b) & + [/\ sem kc s c si, sem_pexpr true gd si e = ok (Vbool b) & if b then ex3_3 (λ k' krec _, k = Sv.union (Sv.union kc k') krec) (λ k' _ sj, sem k' si c' sj) (λ _ krec sj, sem_I krec sj (MkI ii (Cwhile a c e c')) s') else si = s' ∧ kc = k ] | Ccall ini res f args => exists2 xargs, @@ -302,29 +298,29 @@ Qed. Lemma sem_callE ii k s fn s' : sem_call ii k s fn s' → - ex6_14 - (λ f _ _ _ _ _, get_fundef (p_funcs p) fn = Some f) - (λ f _ _ k' _ _, ra_valid f ii k' var_tmp) - (λ f _ _ k' _ _, saved_stack_valid f k') - (λ f _ _ _ _ _, top_stack_aligned f s) - (λ _ _ _ _ _ _, valid_RSP s.(emem) s.(evm)) - (λ f m1 _ _ _ _, alloc_stack s.(emem) f.(f_extra).(sf_align) f.(f_extra).(sf_stk_sz) f.(f_extra).(sf_stk_ioff) f.(f_extra).(sf_stk_extra_sz) = ok m1) - (λ f _ _ _ args _, mapM (λ x : var_i, get_var s.(evm) x) f.(f_params) = ok args) - (λ f _ _ _ args _, all2 check_ty_val f.(f_tyin) args) - (λ f m1 s2' k' _ _, + ex4_10 + (λ f _ _ _, get_fundef (p_funcs p) fn = Some f) + (λ f _ _ k', ra_valid f ii k' var_tmp) + (λ f _ _ k', saved_stack_valid f k') + (λ f _ _ _, top_stack_aligned f s) + (λ _ _ _ _, valid_RSP s.(emem) s.(evm)) + (λ f m1 _ _, alloc_stack s.(emem) f.(f_extra).(sf_align) f.(f_extra).(sf_stk_sz) f.(f_extra).(sf_stk_ioff) f.(f_extra).(sf_stk_extra_sz) = ok m1) +(* (λ f _ _ _ args _, mapM (λ x : var_i, get_var s.(evm) x) f.(f_params) = ok args) + (λ f _ _ _ args _, all2 check_ty_val f.(f_tyin) args) *) + (λ f m1 s2' k', let vm := ra_undef_vm f s.(evm) var_tmp in sem k' {| escs := s.(escs); emem := m1 ; evm := set_RSP m1 vm; |} f.(f_body) s2') - (λ f _ s2' _ _ res, mapM (λ x : var_i, get_var s2'.(evm) x) f.(f_res) = ok res) - (λ f _ _ _ _ res, all2 check_ty_val f.(f_tyout) res) - (λ _ _ s2' _ _ _, valid_RSP s2'.(emem) s2'.(evm)) - (λ f _ s2' _ _ _, +(* (λ f _ s2' _ _ res, mapM (λ x : var_i, get_var s2'.(evm) x) f.(f_res) = ok res) + (λ f _ _ _ _ res, all2 check_ty_val f.(f_tyout) res) *) + (λ _ _ s2' _, valid_RSP s2'.(emem) s2'.(evm)) + (λ f _ s2' _, let m2 := free_stack s2'.(emem) in s' = {| escs := s2'.(escs); emem := m2 ; evm := set_RSP m2 s2'.(evm) |}) - (λ f _ _ k' _ _, + (λ f _ _ k', k = Sv.union k' (Sv.union (ra_vm f.(f_extra) var_tmp) (saved_stack_vm f))). Proof. - case => { ii k s fn s' } /= ii k s s' fn f args m1 s2' res => ok_f ok_ra ok_ss ok_sp ok_RSP ok_alloc ok_args wt_args exec_body ok_RSP' ok_res wt_res /= ->. - by exists f m1 s2' k args res. + case => { ii k s fn s' } /= ii k s s' fn f m1 s2' ok_f ok_ra ok_ss ok_sp ok_RSP ok_alloc exec_body ok_RSP' /= ->. + by exists f m1 s2' k. Qed. (*---------------------------------------------------*) @@ -361,9 +357,9 @@ Section SEM_IND. Definition sem_Ind_assgn : Prop := ∀ (ii: instr_info) (s1 s2 : estate) (x : lval) (tag : assgn_tag) ty (e : pexpr) v v', - sem_pexpr gd s1 e = ok v → + sem_pexpr true gd s1 e = ok v → truncate_val ty v = ok v' → - write_lval gd x v' s1 = ok s2 → + write_lval true gd x v' s1 = ok s2 → Pi_r ii (vrv x) s1 (Cassgn x tag ty e) s2. Definition sem_Ind_opn : Prop := @@ -373,26 +369,26 @@ Section SEM_IND. Definition sem_Ind_syscall : Prop := ∀ (ii: instr_info) (s1 s2 : estate) (o : syscall_t) (xs : lvals) (es : pexprs) scs m ves vs, - mapM (get_var s1.(evm)) (syscall_sig o).(scs_vin) = ok ves -> + mapM (get_var true s1.(evm)) (syscall_sig o).(scs_vin) = ok ves -> exec_syscall (semCallParams:= sCP_stack) s1.(escs) s1.(emem) o ves = ok (scs, m, vs) → - write_lvals gd {| escs := scs; emem := m; evm := vm_after_syscall s1.(evm) |} + write_lvals true gd {| escs := scs; emem := m; evm := vm_after_syscall s1.(evm) |} (to_lvals (syscall_sig o).(scs_vout)) vs = ok s2 → Pi_r ii (Sv.union syscall_kill (vrvs (to_lvals (syscall_sig o).(scs_vout)))) s1 (Csyscall xs o es) s2. Definition sem_Ind_if_true : Prop := ∀ (ii: instr_info) (k: Sv.t) (s1 s2 : estate) (e : pexpr) (c1 c2 : cmd), - sem_pexpr gd s1 e = ok (Vbool true) → + sem_pexpr true gd s1 e = ok (Vbool true) → sem k s1 c1 s2 → Pc k s1 c1 s2 → Pi_r ii k s1 (Cif e c1 c2) s2. Definition sem_Ind_if_false : Prop := ∀ (ii: instr_info) (k: Sv.t) (s1 s2 : estate) (e : pexpr) (c1 c2 : cmd), - sem_pexpr gd s1 e = ok (Vbool false) → + sem_pexpr true gd s1 e = ok (Vbool false) → sem k s1 c2 s2 → Pc k s1 c2 s2 → Pi_r ii k s1 (Cif e c1 c2) s2. Definition sem_Ind_while_true : Prop := ∀ (ii: instr_info) (k k' krec: Sv.t) (s1 s2 s3 s4 : estate) a (c : cmd) (e : pexpr) (c' : cmd), sem k s1 c s2 → Pc k s1 c s2 → - sem_pexpr gd s2 e = ok (Vbool true) → + sem_pexpr true gd s2 e = ok (Vbool true) → sem k' s2 c' s3 → Pc k' s2 c' s3 → sem_I krec s3 (MkI ii (Cwhile a c e c')) s4 → Pi krec s3 (MkI ii (Cwhile a c e c')) s4 → @@ -402,7 +398,7 @@ Section SEM_IND. ∀ (ii: instr_info) (k: Sv.t) (s1 s2 : estate) a (c : cmd) (e : pexpr) (c' : cmd), sem k s1 c s2 → Pc k s1 c s2 → - sem_pexpr gd s2 e = ok (Vbool false) → + sem_pexpr true gd s2 e = ok (Vbool false) → Pi_r ii k s1 (Cwhile a c e c') s2. Hypotheses @@ -424,20 +420,16 @@ Section SEM_IND. Pi_r ii k s1 (Ccall ini res fn args) s2. Definition sem_Ind_proc : Prop := - ∀ (ii: instr_info) (k: Sv.t) (s1 s2: estate) (fn: funname) fd args m1 s2' res, + ∀ (ii: instr_info) (k: Sv.t) (s1 s2: estate) (fn: funname) fd m1 s2', get_fundef (p_funcs p) fn = Some fd → ra_valid fd ii k var_tmp → saved_stack_valid fd k → top_stack_aligned fd s1 → valid_RSP s1.(emem) s1.(evm) → alloc_stack s1.(emem) fd.(f_extra).(sf_align) fd.(f_extra).(sf_stk_sz) fd.(f_extra).(sf_stk_ioff) fd.(f_extra).(sf_stk_extra_sz) = ok m1 → - mapM (λ x : var_i, get_var s1.(evm) x) fd.(f_params) = ok args → - all2 check_ty_val fd.(f_tyin) args → let vm1 := ra_undef_vm fd s1.(evm) var_tmp in sem k {| escs := s1.(escs); emem := m1; evm := set_RSP m1 vm1; |} fd.(f_body) s2' → Pc k {| escs := s1.(escs); emem := m1; evm := set_RSP m1 vm1; |} fd.(f_body) s2' → - mapM (λ x : var_i, get_var s2'.(evm) x) fd.(f_res) = ok res → - all2 check_ty_val fd.(f_tyout) res → valid_RSP s2'.(emem) s2'.(evm) → let m2 := free_stack s2'.(emem) in s2 = {| escs := s2'.(escs); emem := m2 ; evm := set_RSP m2 s2'.(evm) |} → @@ -483,8 +475,8 @@ Section SEM_IND. with sem_call_Ind (ii: instr_info) (k: Sv.t) (s1: estate) (fn: funname) (s2: estate) (s: sem_call ii k s1 fn s2) {struct s} : Pfun ii k s1 fn s2 := match s with - | @EcallRun ii k s1 s2 fn fd args m1 s2' res ok_fd ok_ra ok_ss ok_sp ok_rsp ok_args wt_args ok_m1 exec ok_res wt_res ok_rsp' ok_s2 => - @Hproc ii k s1 s2 fn fd args m1 s2' res ok_fd ok_ra ok_ss ok_sp ok_rsp ok_args wt_args ok_m1 exec (@sem_Ind k _ _ _ exec) ok_res wt_res ok_rsp' ok_s2 + | @EcallRun ii k s1 s2 fn fd m1 s2' ok_fd ok_ra ok_ss ok_sp ok_rsp ok_m1 exec ok_rsp' ok_s2 => + @Hproc ii k s1 s2 fn fd m1 s2' ok_fd ok_ra ok_ss ok_sp ok_rsp ok_m1 exec (@sem_Ind k _ _ _ exec) ok_rsp' ok_s2 end. End SEM_IND. diff --git a/proofs/lang/sem_one_varmap_facts.v b/proofs/lang/sem_one_varmap_facts.v index 7dda83383..7586425fd 100644 --- a/proofs/lang/sem_one_varmap_facts.v +++ b/proofs/lang/sem_one_varmap_facts.v @@ -10,6 +10,8 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. +#[local] Existing Instance withsubword. + Section PROG. Context @@ -21,12 +23,6 @@ Context (p : sprog) (var_tmp : var). -Lemma wf_kill_vars X vm: wf_vm vm -> wf_vm (kill_vars X vm). -Proof. - move=> hwf x; rewrite kill_varsE. - by case: ifP (hwf x) => // _ _; case: (vtype x). -Qed. - Section STACK_STABLE. Infix "≡" := stack_stable (at level 40). @@ -79,8 +75,8 @@ Proof. by []. Qed. Lemma Hproc : sem_Ind_proc p var_tmp Pc Pfun. Proof. - red => ii k s1 s2 fn fd args m1 s2' res ok_fd ok_ra ok_ss ok_sp ok_rsp /Memory.alloc_stackP A ok_args wt_args _. - rewrite /Pc /= => B ok_res wt_res _ ->. + red => ii k s1 s2 fn fd m1 s2' ok_fd ok_ra ok_ss ok_sp ok_rsp /Memory.alloc_stackP A _. + rewrite /Pc /= => B _ ->. red => /=. have C := Memory.free_stackP (emem s2'). split. @@ -172,25 +168,25 @@ Lemma sem_call_valid_RSP ii k s1 fn s2 : sem_call p var_tmp ii k s1 fn s2 → valid_RSP p (emem s1) (evm s2). Proof. - case/sem_callE => fd m s k' args res ok_fd ok_ra ok_ss ok_sp ok_RSP ok_m ok_args wt_args exec_body ok_res wt_res ok_RSP' -> /= _. - rewrite /valid_RSP /set_RSP Fv.setP_eq /top_stack. + case/sem_callE => fd m s k' ok_fd ok_ra ok_ss ok_sp ok_RSP ok_m exec_body ok_RSP' -> /= _. + rewrite /valid_RSP /set_RSP Vm.setP_eq /top_stack. have ok_alloc := Memory.alloc_stackP ok_m. have /= ok_exec := sem_stack_stable exec_body. have ok_free := Memory.free_stackP (emem s). rewrite (fss_frames ok_free) -(ss_frames ok_exec) (ass_frames ok_alloc). rewrite (fss_root ok_free) -(ss_root ok_exec) (ass_root ok_alloc) -/(top_stack (emem s1)). - done. + by rewrite cmp_le_refl. Qed. (* The contents of variables that are not written are preserved. *) Section NOT_WRITTEN. -Local Coercion evm : estate >-> vmap. +Local Coercion evm : estate >-> Vm.t. -Let Pc (k: Sv.t) (s1: estate) (_: cmd) (s2: estate) : Prop := s1 = s2 [\ k]. -Let Pi (k: Sv.t) (s1: estate) (_: instr) (s2: estate) : Prop := s1 = s2 [\ k]. -Let Pi_r (_: instr_info) (k: Sv.t) (s1: estate) (_: instr_r) (s2: estate) : Prop := s1 = s2 [\ k]. -Let Pfun (_: instr_info) (k: Sv.t) (s1: estate) (_: funname) (s2: estate) : Prop := s1 = s2 [\ k]. +Let Pc (k: Sv.t) (s1: estate) (_: cmd) (s2: estate) : Prop := s1 =[\ k] s2 . +Let Pi (k: Sv.t) (s1: estate) (_: instr) (s2: estate) : Prop := s1 =[\ k] s2. +Let Pi_r (_: instr_info) (k: Sv.t) (s1: estate) (_: instr_r) (s2: estate) : Prop := s1 =[\ k] s2. +Let Pfun (_: instr_info) (k: Sv.t) (s1: estate) (_: funname) (s2: estate) : Prop := s1 =[\ k] s2. Local Lemma Hnil_nw : sem_Ind_nil Pc. Proof. by []. Qed. @@ -198,7 +194,7 @@ Proof. by []. Qed. Lemma Hcons_nw : sem_Ind_cons p var_tmp Pc Pi. Proof. move => ki kc x y z i c _ xy _ yz. - exact: vmap_eq_exceptTI yz. + exact: eq_exTI yz. Qed. Lemma HmkI_nw : sem_Ind_mkI p var_tmp Pi Pi_r. @@ -214,8 +210,8 @@ Lemma Hsyscall_nw : sem_Ind_syscall p Pi_r. Proof. move => ii s1 s2 o xs es scs m ves vs hes ho hw. have h1 := vrvsP hw; rewrite /Pi_r. - apply: vmap_eq_exceptT; last by apply: vmap_eq_exceptI h1; SvD.fsetdec. - apply: (vmap_eq_exceptI (s1:= syscall_kill)); first by SvD.fsetdec. + apply: eq_exT; last by apply: eq_exI h1; SvD.fsetdec. + apply: (eq_exI (s2:= syscall_kill)); first by SvD.fsetdec. by move=> y /= /Sv_memP /negPf; rewrite /vm_after_syscall kill_varsE => ->. Qed. @@ -228,8 +224,8 @@ Proof. by []. Qed. Lemma Hwhile_true_nw : sem_Ind_while_true p var_tmp Pc Pi Pi_r. Proof. move => ii k k' krec s1 s2 s3 s4 a c e c' _ ih _ _ ih' _ ihrec. - apply: vmap_eq_exceptTI. - - apply: vmap_eq_exceptTI. + apply: eq_exTI. + - apply: eq_exTI. + exact: ih. exact: ih'. exact: ihrec. @@ -243,24 +239,24 @@ Proof. by []. Qed. Lemma Hproc_nw : sem_Ind_proc p var_tmp Pc Pfun. Proof. - red => ii k s1 s2 fn fd args m1 s2' res ok_fd ok_ra ok_ss ok_sp ok_RSP ok_m1 ok_args wt_args /sem_stack_stable s ih ok_res wt_res ok_RSP' -> r hr /=. - rewrite /set_RSP Fv.setP. + red => ii k s1 s2 fn fd m1 s2' ok_fd ok_ra ok_ss ok_sp ok_RSP ok_m1 /sem_stack_stable s ih ok_RSP' -> r hr /=. + rewrite /set_RSP Vm.setP. case: eqP. - move => ?; subst. have ok_free := Memory.free_stackP (emem s2'). rewrite /top_stack (fss_root ok_free) -(ss_root s) (fss_frames ok_free) -(ss_frames s) /=. have ok_alloc:= Memory.alloc_stackP ok_m1. - rewrite (ass_frames ok_alloc) (ass_root ok_alloc) /= -/(top_stack (emem s1)). + rewrite (ass_frames ok_alloc) (ass_root ok_alloc) /= -/(top_stack (emem s1)) cmp_le_refl. exact: ok_RSP. move => /eqP r_neq_rsp. rewrite -(ih r). 2: SvD.fsetdec. - rewrite /set_RSP Fv.setP_neq // /ra_undef_vm kill_varsE. + rewrite /set_RSP Vm.setP_neq // /ra_undef_vm kill_varsE. case: Sv_memP => //; rewrite /ra_undef; SvD.fsetdec. Qed. Lemma sem_not_written k s1 c s2 : sem p var_tmp k s1 c s2 → - s1 = s2 [\k]. + s1 =[\k] s2. Proof. exact: (sem_Ind @@ -280,7 +276,7 @@ Qed. Lemma sem_I_not_written k s1 i s2 : sem_I p var_tmp k s1 i s2 → - s1 = s2 [\k]. + s1 =[\k] s2. Proof. exact: (sem_I_Ind @@ -300,7 +296,7 @@ Qed. Lemma sem_call_not_written ii k s1 fn s2 : sem_call p var_tmp ii k s1 fn s2 → - s1 = s2 [\k]. + s1 =[\k] s2. Proof. exact: (sem_call_Ind @@ -331,16 +327,6 @@ Proof. intuition SvD.fsetdec. Qed. -Lemma eq_except_disjoint_eq_on s s' x y : - x = y [\s] → - disjoint s s' → - x =[s'] y. -Proof. - rewrite /disjoint /is_true Sv.is_empty_spec => h d r hr. - apply: h. - SvD.fsetdec. -Qed. - (* The contents of RSP and GD registers are preserved. *) Section PRESERVED_RSP_GD. @@ -353,8 +339,7 @@ Let Pfun (_: instr_info) (k: Sv.t) (_: estate) (_: funname) (_: estate) : Prop : Local Lemma Hnil_pm : sem_Ind_nil Pc. Proof. - move => s; rewrite /Pc /disjoint. - SvD.fsetdec. + move => s; rewrite /Pc /disjoint; SvD.fsetdec. Qed. Lemma Hcons_pm : sem_Ind_cons p var_tmp Pc Pi. @@ -403,7 +388,7 @@ Qed. Lemma Hproc_pm : sem_Ind_proc p var_tmp Pc Pfun. Proof. - red => ii k s1 s2 fn fd args m1 s2' res ok_fd ok_ra ok_ss ok_sp ok_RSP ok_m1 ok_args wt_args /sem_stack_stable s ih ok_res wt_res ok_RSP' ->. + red => ii k s1 s2 fn fd m1 s2' ok_fd ok_ra ok_ss ok_sp ok_RSP ok_m1 /sem_stack_stable s ih ok_RSP' ->. rewrite /ra_valid in ok_ra. rewrite /saved_stack_valid in ok_ss. rewrite /Pfun !disjoint_unionE ih /=. @@ -462,7 +447,7 @@ Lemma sem_preserved_RSP_GD k s1 c s2 : sem p var_tmp k s1 c s2 → evm s1 =[magic_variables p] evm s2. Proof. move => exec. - apply: eq_except_disjoint_eq_on. + apply: eq_ex_disjoint_eq_on. - exact: sem_not_written exec. exact: sem_RSP_GD_not_written exec. Qed. @@ -471,7 +456,7 @@ Lemma sem_I_preserved_RSP_GD k s1 i s2 : sem_I p var_tmp k s1 i s2 → evm s1 =[magic_variables p] evm s2. Proof. move => exec. - apply: eq_except_disjoint_eq_on. + apply: eq_ex_disjoint_eq_on. - exact: sem_I_not_written exec. exact: sem_I_RSP_GD_not_written exec. Qed. @@ -530,9 +515,9 @@ Proof. by []. Qed. Lemma validw_stable_proc : sem_Ind_proc p var_tmp Pc Pfun. Proof. - red => ii k s1 s2 fn fd args m1 s2' res ok_fd ok_ra ok_ss ok_sp ok_rsp ok_m1 ok_args wt_args /sem_stack_stable /= ss. + red => ii k s1 s2 fn fd m1 s2' ok_fd ok_ra ok_ss ok_sp ok_rsp ok_m1 /sem_stack_stable /= ss. have A := Memory.alloc_stackP ok_m1. - rewrite /Pc /= => B ok_res wt_res _ -> ptr sz /=. + rewrite /Pc /= => B _ -> ptr sz /=. have C := Memory.free_stackP (emem s2'). by apply (alloc_free_validw_stable A ss B C). Qed. diff --git a/proofs/lang/sem_type.v b/proofs/lang/sem_type.v index bc7f52ff7..b58eba70e 100644 --- a/proofs/lang/sem_type.v +++ b/proofs/lang/sem_type.v @@ -11,6 +11,54 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. +(* ----------------------------------------------------------- *) + +Class WithSubWord := { sw_allowed : bool }. + +Definition nosubword := {| sw_allowed := false |}. +Definition withsubword := {| sw_allowed := true |}. + +Definition compat_type (sw:bool) := + if sw then subtype else eq_op. + +Lemma compat_type_refl b ty : compat_type b ty ty. +Proof. by rewrite /compat_type; case: b. Qed. +#[global]Hint Resolve compat_type_refl : core. + +Lemma compat_type_eq_refl b ty1 ty2 : ty1 = ty2 -> compat_type b ty1 ty2. +Proof. by move=> ->. Qed. + +Lemma compat_type_subtype b t1 t2: + compat_type b t1 t2 -> subtype t1 t2. +Proof. by case: b => //= /eqP ->. Qed. + +Lemma compat_typeE b ty ty' : + compat_type b ty ty' → + match ty' with + | sword sz' => + exists2 sz, ty = sword sz & if b then ((sz ≤ sz')%CMP:Prop) else sz' = sz + | _ => ty = ty' +end. +Proof. + rewrite /compat_type; case: b => [/subtypeE|/eqP ->]; case: ty' => //. + + by move=> ws [ws' [*]]; eauto. + by eauto. +Qed. + +Lemma compat_typeEl b ty ty' : + compat_type b ty ty' → + match ty with + | sword sz => + exists2 sz', ty' = sword sz' & if b then ((sz ≤ sz')%CMP:Prop) else sz = sz' + | _ => ty' = ty + end. +Proof. + rewrite /compat_type; case: b => [/subtypeEl|/eqP ->]. + + by case: ty => // ws [ws' [*]]; eauto. + by case: ty'; eauto. +Qed. + +(* ----------------------------------------------------------- *) Definition sem_t (t : stype) : Type := match t with | sbool => bool diff --git a/proofs/lang/syscall_sem.v b/proofs/lang/syscall_sem.v index 4cfe6d29e..15635639f 100644 --- a/proofs/lang/syscall_sem.v +++ b/proofs/lang/syscall_sem.v @@ -12,6 +12,65 @@ Unset Printing Implicit Defensive. Local Open Scope Z_scope. + + + +Section SourceSysCall. + +Context + {pd: PointerData} + {syscall_state : Type} + {sc_sem : syscall_sem syscall_state} . + +Definition exec_getrandom_u (scs : syscall_state) len vs := + Let _ := + match vs with + | [:: v] => to_arr len v + | _ => type_error + end in + let sd := get_random scs (Zpos len) in + Let t := WArray.fill len sd.2 in + ok (sd.1, [::Varr t]). + +Definition exec_syscall_u + {pd : PointerData} + (scs : syscall_state_t) + (m : mem) + (o : syscall_t) + (vs : values) : + exec (syscall_state_t * mem * values) := + match o with + | RandomBytes len => + Let sv := exec_getrandom_u scs len vs in + ok (sv.1, m, sv.2) + end. + +Lemma exec_syscallPu scs m o vargs vargs' rscs rm vres : + exec_syscall_u scs m o vargs = ok (rscs, rm, vres) → + List.Forall2 value_uincl vargs vargs' → + exists2 vres' : values, + exec_syscall_u scs m o vargs' = ok (rscs, rm, vres') & List.Forall2 value_uincl vres vres'. +Proof. + rewrite /exec_syscall_u; case: o => [ p ]. + t_xrbindP => -[scs' v'] /= h ??? hu; subst scs' m v'. + move: h; rewrite /exec_getrandom_u. + case: hu => // va va' ?? /of_value_uincl_te h [] //. + t_xrbindP => a /h{h}[? /= -> ?] ra hra ??; subst rscs vres. + by rewrite hra /=; eexists; eauto. +Qed. + +Definition mem_equiv m1 m2 := stack_stable m1 m2 /\ validw m1 =2 validw m2. + +Lemma exec_syscallSu scs m o vargs rscs rm vres : + exec_syscall_u scs m o vargs = ok (rscs, rm, vres) → + mem_equiv m rm. +Proof. + rewrite /exec_syscall_u; case: o => [ p ]. + by t_xrbindP => -[scs' v'] /= _ _ <- _. +Qed. + +End SourceSysCall. + Section Section. Context {pd: PointerData} {syscall_state : Type} {sc_sem : syscall_sem syscall_state}. @@ -65,8 +124,6 @@ Proof. by exists vres=> //; apply List_Forall2_refl. Qed. -Definition mem_equiv m1 m2 := stack_stable m1 m2 /\ validw m1 =2 validw m2. - Lemma sem_syscall_equiv o scs m : mk_forall (fun (rm: (syscall_state_t * mem * _)) => mem_equiv m rm.1.2) (sem_syscall o scs m). diff --git a/proofs/lang/type.v b/proofs/lang/type.v index c96d58bac..a20bdbc80 100644 --- a/proofs/lang/type.v +++ b/proofs/lang/type.v @@ -250,3 +250,8 @@ Proof. case: y => //= sy hle;case: z => //= sz;apply: cmp_le_trans hle. Qed. +Lemma is_sword_subtype t1 t2 : subtype t1 t2 -> is_sword t1 = is_sword t2. +Proof. + by case: t1 => //= [/eqP <-|/eqP <-|?|?] //;case:t2. +Qed. + diff --git a/proofs/lang/utils.v b/proofs/lang/utils.v index 0e395b4c5..19d9dd3ee 100644 --- a/proofs/lang/utils.v +++ b/proofs/lang/utils.v @@ -1,7 +1,7 @@ (* ** Imports and settings *) From mathcomp Require Import all_ssreflect. From Coq.Unicode Require Import Utf8. -From Coq Require Import ZArith Zwf Setoid Morphisms CMorphisms CRelationClasses. +From Coq Require Import ZArith Zwf Setoid Morphisms CMorphisms CRelationClasses Psatz. Require Import xseq oseq. From mathcomp Require Import word_ssrZ. @@ -284,6 +284,9 @@ Lemma Let_Let {eT A B C} (a:result eT A) (b:A -> result eT B) (c: B -> result eT ((a >>= b) >>= c) = a >>= (fun a => b a >>= c). Proof. by case: a. Qed. +Lemma LetK {eT T} (r : result eT T) : Let x := r in ok x = r. +Proof. by case: r. Qed. + Definition mapM eT aT bT (f : aT -> result eT bT) : seq aT → result eT (seq bT) := fix mapM xs := match xs with @@ -511,6 +514,10 @@ Proof. by move => n; rewrite /= (h n) /= hy. Qed. +Lemma mapM_ok {eT} {A B:Type} (f: A -> B) (l:list A) : + mapM (eT:=eT) (fun x => ok (f x)) l = ok (map f l). +Proof. by elim l => //= ?? ->. Qed. + Section FOLDM. Context (eT aT bT:Type) (f:aT -> bT -> result eT bT). @@ -555,6 +562,14 @@ Section FOLD2. by elim : xs ys x0 => [|x xs ih] [|y ys] x0 //= ; t_xrbindP => // t _ /ih ->. Qed. + Lemma cat_fold2 ha ta hb tb x v v' : + fold2 ha hb x = ok v -> fold2 ta tb v = ok v' -> + fold2 (ha ++ ta) (hb ++ tb) x = ok v'. + Proof. + elim: ha hb x v => [[] // > [<-] | > hrec []] //= >. + by t_xrbindP => ? -> /hrec{hrec}h/h{h}. + Qed. + End FOLD2. (* ---------------------------------------------------------------- *) @@ -631,6 +646,14 @@ Section MAP2. by constructor. Qed. + Lemma cat_mapM2 ha ta hb tb hl tl : + mapM2 ha hb = ok hl -> mapM2 ta tb = ok tl -> + mapM2 (ha ++ ta) (hb ++ tb) = ok (hl ++ tl). + Proof. + elim: ha hb hl => [[]//?[<-]|> hrec []] //=. + by t_xrbindP=> > -> ? /hrec{hrec}hrec <- /hrec{hrec} ->. + Qed. + End MAP2. Section FMAP. @@ -1562,6 +1585,17 @@ Proof. by move=> hz;rewrite Z2Nat.inj_succ // -addn1 iotaD map_cat /= add0n Z2Nat.id. Qed. +Lemma ziota_cat p y z: 0 <= y -> 0 <= z -> + ziota p y ++ ziota (p + y) z = ziota p (y + z). +Proof. + move=> ? /Z2Nat.id <-; elim: (Z.to_nat _). + + by rewrite Z.add_0_r /= cats0. + move=> ? hrw; rewrite Nat2Z.inj_succ Z.add_succ_r !ziotaS_cat; last 2 first. + + exact: (Ztac.add_le _ _ _ (Zle_0_nat _)). + + exact: Zle_0_nat. + by rewrite catA hrw Z.add_assoc. +Qed. + Lemma in_ziota (p z i:Z) : (i \in ziota p z) = ((p <=? i) && (i hz. @@ -1609,6 +1643,66 @@ Lemma all_ziota p1 p2 (f1 f2: Z -> bool) : all f1 (ziota p1 p2) = all f2 (ziota p1 p2). Proof. by move => h; apply ziota_ind => //= i l /h -> ->. Qed. +Lemma ziota_shift i p : ziota i p = map (fun k => i + k)%Z (ziota 0 p). +Proof. by rewrite !ziotaE -map_comp /comp. Qed. + +Section ZNTH. + Context {A: Type} (dfl: A). + + Fixpoint pnth (m: list A) (p: positive) := + match m with + | [::] => dfl + | a :: m => + match p with + | 1 => a + | q~1 => pnth m q~0 + | q~0 => pnth m (Pos.pred_double q) + end%positive + end. + + Definition znth m (z: Z) : A := + if m is a :: m then + match z with + | Z0 => a + | Zpos p => pnth m p + | Zneg _ => dfl + end + else dfl. + +End ZNTH. + +(* Warning : this is not efficient, it should be used only for proof *) +Definition zindex (T:eqType) (t:T) l := + Z.of_nat (seq.index t l). + +Lemma znthE (A:Type) dfl (l:list A) i : + (0 <= i)%Z -> + znth dfl l i = nth dfl l (Z.to_nat i). +Proof. + case: l; first by rewrite nth_nil. + case: i => // p a m _. + elim/Pos.peano_ind: p a m; first by move => ? []. + move => p /= ih a; rewrite Pos2Nat.inj_succ /=. + case; first by rewrite nth_nil. + move => /= b m. + by case: Pos.succ (Pos.succ_not_1 p) (Pos.pred_succ p) => // _ _ /= ->. +Qed. + +Lemma mem_znth (A:eqType) dfl (l:list A) i : + [&& 0 <=? i & i + znth dfl l i \in l. +Proof. + move=> /andP []/ZleP h0i /ZltP hi. + by rewrite znthE //; apply/mem_nth/ZNltP; rewrite Z2Nat.id. +Qed. + +Lemma znth_index (T : eqType) (x0 x : T) (s : seq T): + x \in s → znth x0 s (zindex x s) = x. +Proof. + move=> hin; rewrite /zindex znthE; last by apply Zle_0_nat. + by rewrite Nat2Z.id nth_index. +Qed. + (* ------------------------------------------------------------------------- *) Lemma sumbool_of_boolET (b: bool) (h: b) : Sumbool.sumbool_of_bool b = left h. @@ -1651,9 +1745,9 @@ Fixpoint merge_tuple (l1 l2: list Type) : ltuple l1 -> ltuple l2 -> ltuple (l1 + end. (* ------------------------------------------------------------------------- *) - Lemma neq_sym (T: eqType) (x y: T) : - (x != y) = (y != x). - Proof. apply/eqP; case: eqP => //; exact: not_eq_sym. Qed. +Lemma neq_sym (T: eqType) (x y: T) : + (x != y) = (y != x). +Proof. apply/eqP; case: eqP => //; exact: not_eq_sym. Qed. (* ------------------------------------------------------------------------- *) Lemma nth_not_default T x0 (s:seq T) n x : @@ -1744,3 +1838,45 @@ Ltac t_eq_rewrites := t_do_rewrites eq_rewrite. Ltac destruct_opn_args := repeat (t_xrbindP=> -[|?]; first done); (t_xrbindP=> -[]; last done). + +(* Attempt to prove [injective f] on [eqType]s by case analysis on the + arguments. *) +Ltac t_inj_cases := + move=> [] [] /eqP h; + apply/eqP. + +(* ------------------------------------------------------------------------- *) + +Module Option. + +Variant option_spec X A o xs xn : option A -> X -> Prop := +| OptionSpecSome : forall a, o = Some a -> option_spec o xs xn (Some a) (xs a) +| OptionSpecNone : o = None -> option_spec o xs xn None xn. + +Lemma oappP R A (f : A -> R) x u : option_spec u f x u (oapp f x u). +Proof. by case: u; constructor. Qed. + +Lemma odfltP T (x : T) u : option_spec u id x u (odflt x u). +Proof. by case: u; constructor. Qed. + +Lemma obindP A R (f : A -> option R) u : option_spec u f None u (obind f u). +Proof. by case: u; constructor. Qed. + +Lemma omapP A R (f : A -> R) u : + option_spec u (fun x => Some (f x)) None u (Option.map f u). +Proof. by case: u; constructor. Qed. + +End Option. + +Lemma cat_inj_head T (x y z : seq T) : x ++ y = x ++ z -> y = z. +Proof. by elim: x y z => // > hrec >; rewrite !cat_cons => -[/hrec]. Qed. + +Lemma cat_inj_tail T (x y z : seq T) : x ++ z = y ++ z -> x = y. +Proof. + elim: z x y => >; first by rewrite !cats0. + by move=> hrec >; rewrite -!cat_rcons => /hrec /rcons_inj[]. +Qed. + +Lemma map_const_nseq A B (l : list A) (c : B) : map (fun=> c) l = nseq (size l) c. +Proof. by elim: l => // > ? /=; f_equal. Qed. + diff --git a/proofs/lang/values.v b/proofs/lang/values.v index 16a1a51bb..aa5177b1d 100644 --- a/proofs/lang/values.v +++ b/proofs/lang/values.v @@ -24,14 +24,25 @@ Proof. by case: s. Qed. Lemma is_undef_t_not_sarr t : is_undef_t t -> is_not_sarr t. Proof. by case: t. Qed. -Definition undef_t t (_: is_not_sarr t) := if is_sword t then sword8 else t. -Arguments undef_t _ _ : clear implicits. +Definition undef_t t := if is_sword t then sword8 else t. +Arguments undef_t _ : clear implicits. -Lemma is_undef_t_undef_t t harr : is_undef_t (undef_t t harr). -Proof. by case: t harr. Qed. +Lemma is_undef_t_undef_t t : is_not_sarr t -> is_undef_t (undef_t t). +Proof. by case: t. Qed. + +Lemma subtype_undef_tP t1 t2 : + subtype (undef_t t1) t2 <-> undef_t t1 = undef_t t2. +Proof. by case: t1 => [ | | len1 | ws1]; case: t2 => [ | | len2 | ws2] //=; split => /eqP. Qed. + +Lemma undef_tK t : undef_t (undef_t t) = undef_t t. +Proof. by case: t. Qed. + +Lemma undef_t_subtype ty : subtype (undef_t ty) ty. +Proof. by rewrite subtype_undef_tP. Qed. +#[global] Hint Resolve undef_t_subtype : core. -Lemma undef_t_id t harr : is_undef_t t -> undef_t t harr = t. -Proof. by case: t harr => // ?? /is_undef_t_sword ->. Qed. +Lemma compat_type_undef_t b t1 t2 : compat_type b t1 t2 -> undef_t t1 = undef_t t2. +Proof. by move=> /compat_type_subtype h; rewrite -subtype_undef_tP (subtype_trans _ h). Qed. (* ** Values * -------------------------------------------------------------------- *) @@ -60,10 +71,25 @@ Lemma Vword_inj sz sz' w w' (e: @Vword sz w = @Vword sz' w') : exists e : sz = sz', eq_rect sz (λ s, (word s)) w sz' e = w'. Proof. by case: e => ?; subst sz' => [[<-]]; exists erefl. Qed. +Lemma ok_word_inj E sz sz' w w' : + ok (@Vword sz w) = Ok E (@Vword sz' w') → + ∃ e : sz = sz', eq_rect sz word w sz' e = w'. +Proof. by move => h; have /Vword_inj := ok_inj h. Qed. + Notation undef_b := (Vundef sbool erefl). Notation undef_i := (Vundef sint erefl). Notation undef_w := (Vundef sword8 erefl). +Definition undef_v t (h: is_not_sarr t) := + Vundef (undef_t t) (is_undef_t_undef_t h). +Arguments undef_v _ _ : clear implicits. + +Definition undef_addr t := + match t with + | sarr n => Varr (WArray.empty n) + | t0 => undef_v t0 erefl + end. + Definition values := seq value. Definition is_defined v := if v is Vundef _ _ then false else true. @@ -80,6 +106,21 @@ Proof. f_equal; exact: Eqdep_dec.UIP_refl_bool. Qed. +Lemma Vundef_eq t1 t2 i1 i2 : + t1 = t2 -> + Vundef t1 i1 = Vundef t2 i2. +Proof. by move=> ?; subst t2; rewrite (Eqdep_dec.UIP_dec Bool.bool_dec i1 i2). Qed. + +Lemma is_undef_undef_t t : + is_undef_t t -> + undef_t t = t. +Proof. by move=> /or3P [] /eqP ->. Qed. + +Lemma undef_addr_eq t1 t2 (i : is_undef_t t2) : + undef_t t1 = t2 -> + undef_addr t1 = Vundef t2 i. +Proof. by move=> ?; subst t2; case: t1 i => //= *; apply Vundef_eq. Qed. + (* ** Type of values * -------------------------------------------------------------------- *) @@ -92,15 +133,16 @@ Definition type_of_val v := | Vundef t _ => t end. -Lemma type_of_valI v : - match type_of_val v with +Lemma type_of_valI v t : + type_of_val v = t -> + match t with | sbool => v = undef_b \/ exists b: bool, v = b | sint => v = undef_i \/ exists i: Z, v = i | sarr len => exists a, v = @Varr len a | sword ws => v = undef_w \/ exists w, v = @Vword ws w end. Proof. - by case: v; last case; move=> > //=; eauto; rewrite undef_x_vundef; eauto. + by move=> <-; case: v; last case; move=> > //=; eauto; rewrite undef_x_vundef; eauto. Qed. Definition check_ty_val (ty:stype) (v:value) := @@ -111,6 +153,9 @@ Definition is_word v := is_sword (type_of_val v). Lemma is_wordI v : is_word v → subtype sword8 (type_of_val v). Proof. by case: v => // [> | [] > //] _; exact: wsize_le_U8. Qed. +Definition DB wdb v := + ~~wdb || (is_defined v || (type_of_val v == sbool)). + (* ** Test for extension of values * -------------------------------------------------------------------- *) @@ -139,8 +184,7 @@ Qed. Lemma value_uincl_refl v: value_uincl v v. Proof. by case: v => //=. Qed. -#[global] -Hint Resolve value_uincl_refl : core. +#[global]Hint Resolve value_uincl_refl : core. Lemma value_uincl_subtype v1 v2 : value_uincl v1 v2 -> @@ -167,6 +211,36 @@ Proof. by apply: subtype_trans. Qed. +Lemma type_of_undef t : type_of_val (undef_addr t) = undef_t t. +Proof. by case: t. Qed. + +Lemma is_defined_undef_addr ty : + is_defined (undef_addr ty) -> exists len, ty = sarr len. +Proof. case: ty => //=; eauto. Qed. + +Lemma subtype_value_uincl_undef t v : + subtype (undef_t t) (type_of_val v) -> + value_uincl (undef_addr t) v. +Proof. by case: t => //= p /eqP /(@sym_eq stype) /type_of_valI [a ->]; apply WArray.uincl_empty. Qed. + +Lemma value_uincl_undef t v : + undef_t t = undef_t (type_of_val v) -> + value_uincl (undef_addr t) v. +Proof. move=> /subtype_undef_tP; apply subtype_value_uincl_undef. Qed. + +Lemma value_uincl_undef_t t1 t2 : + undef_t t1 = undef_t t2 -> + value_uincl (undef_addr t1) (undef_addr t2). +Proof. by move=> h; apply value_uincl_undef; rewrite type_of_undef h undef_tK. Qed. + +Lemma Array_set_uincl n1 n2 + (a1 a1': WArray.array n1) (a2 : WArray.array n2) wz aa i (v:word wz): + value_uincl (Varr a1) (Varr a2) -> + WArray.set a1 aa i v = ok a1' -> + exists2 a2', WArray.set a2 aa i v = ok a2' & + value_uincl (Varr a1) (Varr a2). +Proof. move=> /= hu hs; have [?[]]:= WArray.uincl_set hu hs; eauto. Qed. + (* ** Conversions between values and sem_t * -------------------------------------------------------------------- *) @@ -214,7 +288,7 @@ Proof. by case: v => //= ??; rewrite /WArray.cast; case: ifP. Qed. Definition to_word s v : exec (word s) := match v with | Vword s' w => truncate_word s w - | Vundef (sword s') _ => Error (if (s <= s')%CMP then ErrAddrUndef else ErrType) + | Vundef (sword s') _ => undef_error | _ => type_error end. @@ -413,6 +487,24 @@ Proof. move=> /word_uincl_truncate h/h{h} ->; eauto. Qed. +Lemma value_uincl_defined wdb v1 v2 : + value_uincl v1 v2 -> wdb || is_defined v1 -> wdb || is_defined v2. +Proof. + case: wdb => //=. + case: v1 => [b | z| len t| ws w | t i] /value_uinclE //; try by move=> ->. + + by move=> [? ->]. + by move=> [? [? [-> _]]]. +Qed. + +Lemma value_uincl_DB wdb v1 v2 : + value_uincl v1 v2 -> DB wdb v1 -> DB wdb v2. +Proof. + case: wdb => //. + case: v1 => [b | z| len t| ws w | t i] /value_uinclE; try by move=> ->. + + by move=> [? ->]. + by move=> [? [? [-> _]]]. + by rewrite /DB => /= + /eqP ?; subst t => /eqP <-; rewrite eqxx orbT. +Qed. + (* ** Values implicit downcast (upcast is explicit because of signedness) * -------------------------------------------------------------------- *) @@ -483,6 +575,30 @@ Proof. => ->. Qed. +Lemma truncate_val_subtype_eq ty v v' : + truncate_val ty v = ok v' -> + subtype (type_of_val v) ty -> + v = v'. +Proof. + move=> /truncate_valE; case: v => [b | z | len a | ws w | //]; try by move=> [_ ->]. + move=> [ws' [w' [-> /truncate_wordP [h ->]->]]] /= /(cmp_le_antisym h) ?; subst ws'. + by rewrite zero_extend_u. +Qed. + +Lemma truncate_val_idem (t : stype) (v v' : value) : + truncate_val t v = ok v' -> truncate_val t v' = ok v'. +Proof. + move=> /truncate_valI; case: v' => [b[]|z[]|len a[]|ws w[?[?[]]]| ] //= -> //=. + + by move=> _; rewrite /truncate_val /= WArray.castK. + by move=> _ _; rewrite /truncate_val /= truncate_word_u. +Qed. + +Lemma truncate_val_defined ty v v' : truncate_val ty v = ok v' -> is_defined v'. +Proof. by move=> /truncate_valI; case: v'. Qed. + +Lemma truncate_val_DB wdb ty v v' : truncate_val ty v = ok v' -> DB wdb v'. +Proof. by case: wdb => //; move=> /truncate_valI; case: v'. Qed. + (* ----------------------------------------------------------------------- *) Lemma value_uincl_truncate ty x y x' : diff --git a/proofs/lang/var.v b/proofs/lang/var.v index 5900cab74..8d472b26f 100644 --- a/proofs/lang/var.v +++ b/proofs/lang/var.v @@ -76,243 +76,6 @@ Module MvMake (I:IDENT). Lemma var_surj (x:var) : x = Var x.(vtype) x.(vname). Proof. by case: x. Qed. - Module Mv. - - Record rt_ (to:stype -> Type) := MkT { - dft : forall (x:var) ,to x.(vtype); - tbl : Mt.t (fun ty => Mid.t (to ty)); - }. - - Definition t := rt_. - - Definition empty {to} (dft : forall (x:var), to x.(vtype)) : t to := {| - dft := dft; - tbl := Mt.empty _; - |}. - - Definition get {to} (m: t to) (x:var) : to x.(vtype) := - match (m.(tbl).[x.(vtype)])%mt with - | Some mi => - match mi.[x.(vname)] with - | Some v => v - | None => m.(dft) x - end - | None => m.(dft) x - end. - - Definition set {to} (m: t to) (x:var) (v:to x.(vtype)) : t to := - let mi := - match (m.(tbl).[x.(vtype)])%mt with - | Some mi => mi - | None => Mid.empty _ - end in - let mi := mi.[x.(vname) <- v] in - {| dft := m.(dft); - tbl := (m.(tbl).[x.(vtype) <- mi])%mt; |}. - - Definition remove to (m: t to) x := - match (m.(tbl).[x.(vtype)])%mt with - | Some mi => - {| dft := m.(dft); - tbl := m.(tbl).[x.(vtype) <- Mid.remove mi x.(vname)]%mt; |} - | None => m - end. - - Definition indom to x (m: t to) := - match (m.(tbl).[x.(vtype)])%mt with - | Some mi => - match mi.[x.(vname)] with - | Some _ => true - | None => false - end - | None => false - end. - - Definition map {to1 to2} (f:forall t, to1 t -> to2 t) (m: t to1) : t to2 := - {| dft := fun (x:var) => f x.(vtype) (dft m x); - tbl := Mt.map (fun t mi => Mid.map (f t) mi) m.(tbl); |}. - - Definition map2 {to1 to2 to3} - (fd:forall x, to3 x.(vtype)) - (f:forall x, to1 x.(vtype) -> to2 x.(vtype) -> to3 x.(vtype)) - (m1: t to1) (m2: t to2): t to3 := - let dft1 := m1.(dft) in - let dft2 := m2.(dft) in - let doty ty mi1 mi2 := - match mi1, mi2 with - | None, None => None - | Some mi1, None => - Some (Mid.mapi - (fun id (v1:to1 ty) => let x := Var ty id in (f x v1 (dft2 x):to3 ty)) - mi1) - | None , Some mi2 => - Some (Mid.mapi - (fun id (v2:to2 ty) => let x := Var ty id in (f x (dft1 x) v2:to3 ty)) - mi2) - | Some mi1, Some mi2 => - Some (Mid.map2 (fun id (o1:option (to1 ty)) (o2: option (to2 ty)) => - match o1, o2 with - | None , None => None - | Some v1, None => let x := Var ty id in Some (f x v1 (dft2 x)) - | None , Some v2 => let x := Var ty id in Some (f x (dft1 x) v2) - | Some v1, Some v2 => let x := Var ty id in (Some (f x v1 v2): option (to3 ty)) - end) mi1 mi2) - end in - {| dft := fd; - tbl := Mt.map2 doty m1.(tbl) m2.(tbl) |}. - - Local Notation "vm .[ x ]" := (@get _ vm x). - Local Notation "vm .[ x <- v ]" := (@set _ vm x v). - - Lemma get0 {to} (dft: forall x, to x.(vtype)) (x:var) : (empty dft).[x] = dft x. - Proof. by rewrite /empty /get Mt.get0. Qed. - - Lemma setP_eq {to} (m:t to) (x:var) (v:to x.(vtype)) : m.[x <- v].[x] = v. - Proof. by rewrite /set /get Mt.setP_eq Mid.setP_eq. Qed. - - Lemma setP_neq {to} (m:t to) x y (v:to x.(vtype)) : - x != y -> m.[x <- v].[y] = m.[y]. - Proof. - move=> neq;rewrite /set /get. - case : (boolP ((vtype x) == (vtype y))) => [/eqP eq | ?] /=; - last by rewrite Mt.setP_neq. - move: v;rewrite eq => v; rewrite Mt.setP_eq Mid.setP_neq. - + by case: (_.[_])%mt => //; rewrite Mid.get0. - by apply: contra neq=> /eqP eqn;rewrite (var_surj x) eq eqn -var_surj. - Qed. - - Lemma indom0 {to} (dft: forall x, to x.(vtype)) (x:var): ~~indom x (empty dft). - Proof. by rewrite /indom Mt.get0. Qed. - - Lemma indom_set_eq {to} (m:t to) (x:var) (v:to x.(vtype)): indom x m.[x<-v]. - Proof. by rewrite /indom /set /= Mt.setP_eq Mid.setP_eq. Qed. - - Lemma indom_set_neq {to} (m:t to) (x y:var) (v:to x.(vtype)): - x !=y -> indom y m.[x<- v] = indom y m. - Proof. - move=> H;rewrite /indom /set /=. - case: (vtype x =P vtype y)=> [Heq | /eqP ?];last by rewrite Mt.setP_neq. - rewrite -Heq Mt.setP_eq Mid.setP_neq. - + by case: (_.[_])%mt => //;rewrite Mid.get0. - by apply: contra H=> /eqP eqn;rewrite (var_surj x) Heq eqn -var_surj. - Qed. - - Lemma indom_setP {to} (m:t to) (x y:var) (v:to x.(vtype)): - indom y m.[x<-v] = (x == y) || indom y m. - Proof. - case : (boolP (x==y)) => [/eqP <-| ] /=;first by rewrite indom_set_eq. - by apply indom_set_neq. - Qed. - - Lemma indom_getP {to} (m:t to) x: ~~indom x m -> m.[x] = dft m x. - Proof. - by rewrite /indom /get;case: Mt.get => // ?;case: Mid.get. - Qed. - - Lemma dft_setP {to} (m:t to) (x:var) (v:to x.(vtype)): dft (set m v) = dft m. - Proof. done. Qed. - - Lemma removeP_eq to (m: t to) x: (remove m x).[x] = dft m x. - Proof. - rewrite /remove/get;case H: (tbl m).[_]%mt => [mi|] /=;last by rewrite H. - by rewrite Mt.setP_eq removeP_eq. - Qed. - - Lemma removeP_neq to (m: t to) x y: x != y -> (remove m x).[y] = m.[y]. - Proof. - rewrite /remove/get=> Hxy;case: (vtype x =P vtype y) => /= [Heq | /eqP Hneq]. - + rewrite Heq;case H: (tbl m).[_]%mt => [mi|] /=;last by rewrite H. - rewrite Mt.setP_eq Mid.removeP_neq //. - by apply: contra Hxy => /eqP Hn;rewrite (var_surj x) (var_surj y) Heq Hn. - by case H: (tbl m).[_]%mt => [mi|] //=;rewrite Mt.setP_neq. - Qed. - - Lemma indom_removeP to (m: t to) x y: - indom y (remove m x) = (x != y) && indom y m. - Proof. - rewrite /remove/indom. - case: (vtype x =P vtype y) => /= [Heq | /eqP Hneq]. - + rewrite -Heq;case H: ((tbl m).[_]%mt) => [mi|]/=;last by rewrite H andbC. - rewrite Mt.setP_eq Mid.removeP. - case: (_ =P _) => [Heqn | Hneqn ]. - + by rewrite {1}(var_surj x) {1}(var_surj y) -Heq Heqn eq_refl. - have -> // : x != y. - by apply /eqP=> Hx;apply Hneqn;rewrite Hx. - have -> : x != y. - + by apply /eqP=> Hx;move:Hneq;rewrite Hx eq_refl. - by case H: ((tbl m).[_]%mt) => [mi|] //=;rewrite Mt.setP_neq. - Qed. - - Lemma indom_removeP_eq to (m: t to) x: - ~~indom x (remove m x). - Proof. by rewrite indom_removeP eq_refl. Qed. - - Lemma indom_removeP_neq to (m: t to) x y: x != y -> - indom y (remove m x) = indom y m. - Proof. by rewrite indom_removeP=> ->. Qed. - - Lemma dft_removeP to (m: t to) x: dft (remove m x) = dft m. - Proof. by rewrite /dft/remove;case:(tbl m).[_]%mt. Qed. - - Lemma mapP {to1 to2} (f:forall t, to1 t -> to2 t) (m: t to1) x: - (map f m).[x] = f x.(vtype) m.[x]. - Proof. - rewrite /map /get /=. - rewrite Mt.mapP;case: Mt.get => //= mi. - by rewrite Mid.mapP; case: Mid.get. - Qed. - - Lemma indom_mapP {to1 to2} (f:forall t, to1 t -> to2 t) (m: t to1) x: - indom x (map f m) = indom x m. - Proof. - rewrite /map /indom /= Mt.mapP. - by case: Mt.get => //= ?;rewrite Mid.mapP;case Mid.get. - Qed. - - Lemma dft_mapP {to1 to2} (f:forall t, to1 t -> to2 t) (m: t to1): - dft (map f m) = fun x : var => f (vtype x) (dft m x). - Proof. done. Qed. - - Lemma map2Pred {to1 to2 to3} - (fd: forall x, to3 x.(vtype)) - (f:forall x, to1 x.(vtype) -> to2 x.(vtype) -> to3 x.(vtype)) m1 m2 x P: - (~~indom x m1 -> ~~indom x m2 -> P (f x (dft m1 x) (dft m2 x)) -> P (fd x)) -> - P (f x m1.[x] m2.[x]) -> P (map2 fd f m1 m2).[x]. - Proof. - rewrite /indom /map2 /get /= Mt.map2P //. - case: ((tbl m1).[vtype x])%mt=>[mi1|];case: ((tbl m2).[vtype x])%mt=>[mi2|];last by auto. - + rewrite Mid.map2P //. - by case: (Mid.get mi1 (vname x));case: (Mid.get mi2 (vname x))=> //; - last (by auto); case: (x) P. - + by rewrite Mid.mapiP //;case: (Mid.get mi1 (vname x));case: (x) P =>//=;auto. - by rewrite Mid.mapiP //;case: (Mid.get mi2 (vname x));case: (x) P=> //=;auto. - Qed. - - Lemma map2P {to1 to2 to3} - (fd: forall x, to3 x.(vtype)) - (f:forall x, to1 x.(vtype) -> to2 x.(vtype) -> to3 x.(vtype)) m1 m2 x: - (~~indom x m1 -> ~~indom x m2 -> fd x = f x (dft m1 x) (dft m2 x)) -> - (map2 fd f m1 m2).[x] = f x m1.[x] m2.[x]. - Proof. by apply map2Pred => // ?? H1 H2;rewrite H2 // H1. Qed. - - Lemma indom_map2P {to1 to2 to3} fd - (f:forall x, to1 x.(vtype) -> to2 x.(vtype) -> to3 x.(vtype)) m1 m2 x: - indom x (map2 fd f m1 m2) = indom x m1 || indom x m2. - Proof. - rewrite /map2 /indom /= Mt.map2P //. - case: ((tbl m1).[vtype x])%mt=> [mi1 | ];case: ((tbl m2).[vtype x])%mt => [mi2 | ] //. - + by rewrite Mid.map2P //; case: Mid.get => [?|] /=;case: Mid.get. - + by rewrite Mid.mapiP;case: Mid.get. - by rewrite Mid.mapiP;case: Mid.get. - Qed. - - Lemma dft_map2P {to1 to2 to3} fd - (f:forall x, to1 x.(vtype) -> to2 x.(vtype) -> to3 x.(vtype)) m1 m2: - dft (map2 fd f m1 m2) = fd. - Proof. done. Qed. - - End Mv. - End MvMake. (* ** Types for idents @@ -327,13 +90,6 @@ Notation vname := Var.vname. Notation Var := Var.Var. Notation vbool i := {| vtype := sbool; vname := i; |}. -Declare Scope mvar_scope. -Delimit Scope mvar_scope with mv. -Notation "vm .[ x ]" := (@Mv.get _ vm x) : mvar_scope. -Notation "vm .[ x <- v ]" := (@Mv.set _ vm x v) : mvar_scope. -Arguments Mv.get to m%mvar_scope x. -Arguments Mv.set to m%mvar_scope x v. - Lemma vtype_diff x x': vtype x != vtype x' -> x != x'. Proof. by apply: contra => /eqP ->. Qed. @@ -368,120 +124,11 @@ Definition is_regx (x: var) : bool := * but extentianality is permited * -------------------------------------------------------------------- *) -Module Type FvT. - Parameter t : (stype -> Type) -> Type. - Parameter empty : - forall {to:stype -> Type} (dval : forall (x:var), to x.(vtype)), t to. - - Parameter get : - forall {to:stype -> Type} (vm:t to) (x:var), to x.(vtype). - - Parameter set : - forall {to:stype -> Type} (vm : t to) x (v : to x.(vtype)), t to. - - Axiom get0 : forall to dval x, @get to (empty dval) x = dval x. - - Axiom setP_eq : forall to (vm:t to) x (v:to x.(vtype)), - get (@set _ vm x v) x = v. - - Axiom setP_neq : forall to (vm:t to) x y (v:to x.(vtype)), - x != y -> get (@set _ vm x v) y = get vm y. - - Axiom setP : ∀ to (vm: t to) x y (v: to x.(vtype)), - get (@set _ vm x v) y = - match x =P y with - | ReflectT x_eq_y => ecast _ _ x_eq_y v - | _ => get vm y - end. - - Definition ext_eq {to} (vm1 vm2 : t to) := - forall x, get vm1 x = get vm2 x. - -End FvT. - -Module Fv : FvT. - - Definition t := Mv.t. - - Definition empty := @Mv.empty. - - Definition get := @Mv.get. - - Definition set := @Mv.set. - - Lemma get0 to dval x : @get to (empty dval) x = dval x. - Proof. by apply: Mv.get0. Qed. - - Lemma setP_eq to (vm:t to) x (v:to x.(vtype)) : - get (@set _ vm x v) x = v. - Proof. apply Mv.setP_eq. Qed. - - Lemma setP_neq to (vm:t to) x y (v:to x.(vtype)) : - x != y -> get (@set _ vm x v) y = get vm y. - Proof. apply Mv.setP_neq. Qed. - - Lemma setP to (vm: t to) x y (v: to x.(vtype)) : - get (@set _ vm x v) y = - match x =P y with - | ReflectT x_eq_y => ecast _ _ x_eq_y v - | _ => get vm y - end. - Proof. - case: (x =P y). - + move => ?; subst; exact: setP_eq. - move => /eqP; exact: setP_neq. - Qed. - - Definition ext_eq {to} (vm1 vm2 : t to) := - forall x, get vm1 x = get vm2 x. - -End Fv. - -Declare Scope vmap_scope. -Delimit Scope vmap_scope with vmap. -Notation "vm .[ id ]" := (Fv.get vm id) : vmap_scope. -Notation "vm .[ k <- v ]" := (@Fv.set _ vm k v) : vmap_scope. -Notation "vm1 =v vm2" := (Fv.ext_eq vm1 vm2) (at level 70, no associativity) : vmap_scope. -Arguments Fv.get to vm%vmap_scope x. -Arguments Fv.set to vm%vmap_scope x v. -Arguments Fv.ext_eq to vm1%vmap_scope vm2%vmap_scope. - -(* Attempt to simplify goals of the form [vm.[y0 <- z0]...[yn <- zn].[x]]. *) -Ltac t_vm_get := - repeat ( - rewrite Fv.setP_eq - || (rewrite Fv.setP_neq; last (apply/eqP; by [|apply/nesym])) - ). - (* Deduce inequalities from [~ Sv.In x (Sv.add y0 (... (Sv.add yn s)))]. *) Ltac t_notin_add := repeat (move=> /Sv.add_spec /Decidable.not_or [] ?); move=> ?. -Module Type Vmap. - - Parameter t : (stype -> Type) -> Type. - - Parameter empty : forall to, (forall (x:var), to x.(vtype)) -> t to. - - Parameter get : forall {to}, t to -> forall (x:var), to x.(vtype). - - Parameter set : forall {to}, t to -> forall (x:var), to x.(vtype) -> t to. - - Parameter get0 : - forall {to} (dft: forall x, to x.(vtype)) (x:var), - get (empty dft) x = dft x. - - Parameter setP_eq : - forall {to} (m:t to) (x:var) (v:to x.(vtype)), - get (@set to m x v) x = v. - - Parameter setP_neq : - forall {to} (m:t to) x y (v:to x.(vtype)), - x != y -> get (@set to m x v) y = get m y. - -End Vmap. - (* ** Finite set of variables (computable) * * -------------------------------------------------------------------- *) @@ -642,6 +289,17 @@ Proof. exact: orbT. Qed. +Lemma sv_of_list_fold T f l s : + Sv.Equal (foldl (λ (s : Sv.t) (r : T), Sv.add (f r) s) s l) (Sv.union s (sv_of_list f l)). +Proof. + rewrite /sv_of_list; elim: l s => //= [ | a l hrec] s; first by SvD.fsetdec. + rewrite hrec (hrec (Sv.add _ _)); SvD.fsetdec. +Qed. + +Lemma sv_of_list_cons T (f : T -> _) x l : + Sv.Equal (sv_of_list f (x::l)) (Sv.add (f x) (sv_of_list f l)). +Proof. rewrite /sv_of_list /= sv_of_list_fold; SvD.fsetdec. Qed. + Lemma disjoint_subset_diff xs ys : disjoint xs ys -> Sv.Subset xs (Sv.diff xs ys). diff --git a/proofs/lang/varmap.v b/proofs/lang/varmap.v new file mode 100644 index 000000000..0e82e5892 --- /dev/null +++ b/proofs/lang/varmap.v @@ -0,0 +1,1178 @@ +From mathcomp Require Import all_ssreflect all_algebra. +Require Import ZArith Setoid Morphisms. +Require Export var type values. +Import Utf8 ssrbool. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +(* ----------------------------------------------------------- *) +Section Section. + +Context {wsw: WithSubWord}. + +Definition compat_val ty v := + compat_type (sw_allowed || ~~is_defined v) (type_of_val v) ty. + +Lemma compat_valE ty v: compat_val ty v -> + match v with + | Vbool _ => ty = sbool + | Vint _ => ty = sint + | Varr len _ => ty = sarr len + | Vword ws _ => + exists2 ws', ty = sword ws' & + if sw_allowed then ((ws <= ws')%CMP:Prop) else ws = ws' + | Vundef ty' _ => subtype ty' ty + end. +Proof. + rewrite /compat_val; case: v => [b|i|len t|ws w|t h] /= /compat_typeEl //. + + by rewrite orbF => -[ws'] -> ?; eauto. + rewrite orbT => {h}; case: t => > h //; try by subst ty. + by case: h => ? -> /=. +Qed. + +Lemma compat_valEl ty v: compat_val ty v -> + match ty with + | sbool => v = undef_b \/ exists b, v = Vbool b + | sint => v = undef_i \/ exists i, v = Vint i + | sarr len => exists t, v = @Varr len t + | sword ws => + v = undef_w \/ + exists ws', exists2 w:word ws', v = Vword w & + if sw_allowed then ((ws' <= ws)%CMP:Prop) else ws = ws' + end. +Proof. + rewrite /compat_val => /compat_typeE; case: ty => [ | |len|ws [ws']] /type_of_valI //. + move=> [ | [w]] -> /=; auto. + rewrite orbF; right; eauto. +Qed. + +Definition truncatable wdb ty v := + match v, ty with + | Vbool _, sbool => true + | Vint _, sint => true + | Varr p _, sarr p' => p == p' + (* TODO: change the order of the conditions to simplify proofs + suggestion: ws' ≤ ws || sw_allowed || ~~ wdb *) + | Vword ws w, sword ws' => ~~wdb || (sw_allowed || (ws' <= ws)%CMP) + | Vundef t _, _ => subtype t ty + | _, _ => false + end. + +Lemma truncatable_arr wdb len a : truncatable wdb (sarr len) (@Varr len a). +Proof. by rewrite /truncatable /= eqxx. Qed. + +Definition vm_truncate_val ty v := + match v, ty with + | Vbool _, sbool => v + | Vint _, sint => v + | Varr p _, sarr p' => if p == p' then v else undef_addr ty + | Vword ws w, sword ws' => + if (sw_allowed || (ws' <= ws)%CMP) then + if (ws <= ws')%CMP then Vword w else Vword (zero_extend ws' w) + else undef_addr ty + | Vundef t _, _ => undef_addr ty + | _, _ => undef_addr ty + end. + +Lemma if_zero_extend_w ws ws' (w:word ws) : + (if (ws ≤ ws')%CMP then Vword w else Vword (zero_extend ws' w)) = + if (ws' ≤ ws)%CMP then Vword (zero_extend ws' w) else Vword w. +Proof. + case: ifPn. + + by case: ifPn => // h1 h2; have ? := cmp_le_antisym h1 h2; subst ws'; rewrite zero_extend_u. + by rewrite cmp_nle_lt => h; rewrite (cmp_lt_le h). +Qed. + +Lemma compat_val_truncatable wdb t v : + compat_val t v -> + truncatable wdb t v. +Proof. + move=> /compat_valE; rewrite /truncatable /=. + case: v => [b ->|z ->|len a ->|ws w [ws' -> h]|t' i] //=. + by apply/orP; right; case: sw_allowed h => //= ->. +Qed. + +Lemma subtype_truncatable wdb t v : + subtype t (type_of_val v) -> + truncatable wdb t v. +Proof. + rewrite /truncatable. + case: v => [b|z|len a|ws w|t' i] /=. + 1-3: by move=> /subtypeE ->. + by move=> /subtypeE [ws'] [-> ->]; rewrite !orbT. + case/or3P: i => /eqP -> /subtypeE. + 1-2: by move=> ->. + by move=> [? [-> ?]] /=. +Qed. + +Lemma truncatable_type_of wdb v : + truncatable wdb (type_of_val v) v. +Proof. by apply subtype_truncatable. Qed. + +(* TODO: rename this lemma and its siblings; vm_truncate_val -> truncatable *) +Lemma vm_truncate_valE_wdb wdb ty v : + truncatable wdb ty v -> + match v with + | Vbool b => ty = sbool /\ vm_truncate_val ty v = b + | Vint i => ty = sint /\ vm_truncate_val ty v = i + | Varr len a => ty = sarr len /\ vm_truncate_val ty v = Varr a + | Vword ws w => + exists ws', + [/\ ty = sword ws', ~~wdb || (sw_allowed || (ws' <= ws)%CMP) & + vm_truncate_val ty v = + (if sw_allowed || (ws' ≤ ws)%CMP then + if (ws ≤ ws')%CMP then Vword w else Vword (zero_extend ws' w) + else undef_addr (sword ws'))] + + | Vundef t h => subtype t ty /\ vm_truncate_val ty v = v + end. +Proof. + rewrite /truncatable /=. + case: v => [b|z|len a|ws w|t i] //=; last first. + + move=> h; split => //. + apply: undef_addr_eq. + move: h => /(subtype_trans (undef_t_subtype t)) /subtype_undef_tP <-. + by rewrite (is_undef_undef_t i). + all: case: ty => // >. + + move=> h; eexists; split; eauto. + by move=> /eqP <-; rewrite eqxx. +Qed. + +Lemma vm_truncate_valE ty v : + truncatable true ty v -> + match v with + | Vbool b => ty = sbool /\ vm_truncate_val ty v = b + | Vint i => ty = sint /\ vm_truncate_val ty v = i + | Varr len a => ty = sarr len /\ vm_truncate_val ty v = Varr a + | Vword ws w => + exists ws', + [/\ ty = sword ws', (sw_allowed || (ws' <= ws)%CMP) & + vm_truncate_val ty v = if (ws <= ws')%CMP then Vword w else Vword (zero_extend ws' w)] + | Vundef t h => subtype t ty /\ vm_truncate_val ty v = v + end. +Proof. + move=> /vm_truncate_valE_wdb; case: v => //. + by move=> > [] ws [/= -> h ?]; exists ws; split; auto; rewrite h. +Qed. + +Lemma compat_val_undef_addr t : compat_val t (undef_addr t). +Proof. by rewrite /compat_val; case: t => //= w; rewrite orbT /= wsize_le_U8. Qed. +Hint Resolve compat_val_undef_addr : core. + +Lemma vm_truncate_val_compat v ty : compat_val ty (vm_truncate_val ty v). +Proof. +Opaque undef_addr. + case : v => [b | i | p t | ws w | t ht] => //=. + 1-2: by case: ty => [||len|ws'] //=; rewrite /compat_val. + + by case: ty => [||len|ws'] //=; case: eqP => [<-|//]; rewrite /compat_val. + case: ty => [||len|ws'] //=; case: ifP => //= h; rewrite /compat_val; case: ifP => //=. + by case: sw_allowed h => //= h1 h2; rewrite (cmp_le_antisym h2 h1). +Transparent undef_addr. +Qed. + +Lemma vm_truncate_valEl_wdb wdb ty v : + truncatable wdb ty v -> + let vt := vm_truncate_val ty v in + match ty with + | sbool => + v = undef_b /\ vt = undef_b \/ exists2 b, v = Vbool b & vt = Vbool b + | sint => v = undef_i /\ vt = undef_i \/ exists2 i, v = Vint i & vt = Vint i + | sarr len => exists2 t, v = @Varr len t & vt = Varr t + | sword ws => + v = undef_w /\ vt = undef_w \/ + exists ws' (w:word ws'), + [/\ v = Vword w, + ~~wdb || (sw_allowed || (ws <= ws')%CMP) & + vm_truncate_val ty v = + (if sw_allowed || (ws ≤ ws')%CMP then + if (ws' ≤ ws)%CMP then Vword w else Vword (zero_extend ws w) + else undef_addr (sword ws))] + end. +Proof. + move=> /vm_truncate_valE_wdb /=; case: v => /=. + 1,2: by move=> ? [-> ]; eauto. + + by move=> > [-> ] _; rewrite eqxx; eauto. + + move=> ws w [ws' [-> h ?]]; right. + do 2!eexists; split; eauto. + move=> t i [/subtypeEl + ->]. + have /or3P [] := i => /eqP ?; subst t. + 1,2: by move=> ->;left; split; apply Vundef_eq. + by move=> [sz' [-> ?]]; left; split; apply Vundef_eq. +Qed. + +Lemma vm_truncate_valEl ty v : + truncatable true ty v -> + let vt := vm_truncate_val ty v in + match ty with + | sbool => + v = undef_b /\ vt = undef_b \/ exists2 b, v = Vbool b & vt = Vbool b + | sint => v = undef_i /\ vt = undef_i \/ exists2 i, v = Vint i & vt = Vint i + | sarr len => exists2 t, v = @Varr len t & vt = Varr t + | sword ws => + v = undef_w /\ vt = undef_w \/ + exists ws' (w:word ws'), + [/\ v = Vword w, + vt = if (ws' <= ws)%CMP then Vword w else Vword (zero_extend ws w) & + sw_allowed || (ws <= ws')%CMP] + end. +Proof. + move=> /vm_truncate_valEl_wdb /=; case: ty => // ? []; auto. + move=> [? [? [-> h ->]]]; rewrite h; right; do 2!eexists; split; eauto. +Qed. + +Lemma vm_truncate_val_subtype ty v: + (sw_allowed -> ~is_sword ty) -> DB true v -> + truncatable true ty v -> + subtype ty (type_of_val v). +Proof. + move=> hna hdb htr. + move/vm_truncate_valE: htr hdb; case: v => [b | i | p t | ws w | t ht] /=. + 1,2,3: by move=> [-> ]. + + by move=> [ws' [? + _] _]; subst ty; case: sw_allowed hna => //= /(_ erefl). + by rewrite /DB /= => -[] + _ /eqP ?; subst t => /subtypeEl ->. +Qed. + +Lemma vm_truncate_value_uincl wdb t v : + truncatable wdb t v → value_uincl (vm_truncate_val t v) v. +Proof. + move=> /vm_truncate_valE_wdb; case: v. + 1-3: by move=> > [-> ]// ->. + + move => ws w [ws' [-> ? ->]]. + case: ifPn => //= _. + case: ifPn => //; rewrite cmp_nle_lt => hlt /=. + by apply/word_uincl_zero_ext/cmp_lt_le. + by move=> > [? ->]. +Qed. + +Lemma vm_truncate_val_DB wdb ty v: + truncatable wdb ty v -> + DB wdb v = DB wdb (vm_truncate_val ty v). +Proof. + case: wdb => //. + move=> /vm_truncate_valE; case: v => [b [_ ->]| z [_ ->] | len a [_ ->] | ws w | t i [_ ->]] //=. + by move=> [ws' [_ _ ->]]; case: ifP. +Qed. + +Lemma vm_truncate_val_defined wdb ty v: + truncatable wdb ty v -> + (~~wdb || is_defined v) = (~~wdb || is_defined (vm_truncate_val ty v)). +Proof. + case: wdb => //. + move=> /vm_truncate_valE; case: v => [b [_ ->]| z [_ ->] | len a [_ ->] | ws w | t i [_ ->]] //=. + by move=> [ws' [_ _ ->]]; case: ifP. +Qed. + +Lemma compat_value_uincl_undef ty v : + compat_val ty v -> + value_uincl (undef_addr ty) v. +Proof. + move=> /compat_typeEl. + case: v => //= [b -> | z -> | len a -> | ws w [ws' -> hle] | t i] //=. + + by apply WArray.uincl_empty. + by (case: (is_undef_tE i) => ?; subst t) => [ -> | -> | [ws ->]]. +Qed. + +Lemma vm_truncate_val_eq ty v : + type_of_val v = ty -> vm_truncate_val ty v = v. +Proof. + rewrite /vm_truncate_val => <-; case: v => //= [ len a | ws w | t h]. + + by rewrite eqxx. + + by rewrite cmp_le_refl orbT. + by apply/undef_addr_eq/is_undef_undef_t. +Qed. + +Lemma vm_truncate_val_subtype_word v ws: + DB true v -> + subtype (sword ws) (type_of_val v) -> + truncatable true (sword ws) v -> + exists2 w : word ws, vm_truncate_val (sword ws) v = Vword w & to_word ws v = ok w. +Proof. + move=> hd /subtypeEl [ws' [/type_of_valI [? | [w ?]]]] hle1; subst v => //=. + rewrite if_zero_extend_w hle1 truncate_word_le //= => ->; eauto. +Qed. + +Lemma to_word_vm_truncate_val wdb ws t v w: + t = sword ws -> + to_word ws v = ok w -> + [/\ truncatable wdb t v, vm_truncate_val t v = (Vword w), DB wdb v & is_defined v]. +Proof. by move=> -> /to_wordI' [sz' [w' [hle -> ->]]] /=; rewrite /truncatable /DB if_zero_extend_w hle !orbT. Qed. + +Lemma compat_truncatable wdb ty1 ty2 v: + compat_type sw_allowed ty1 ty2 -> + truncatable wdb ty1 v -> + truncatable wdb ty2 v. +Proof. + rewrite /compat_type; case: ifP => hwsw; last by move=> /eqP ->; eauto. + move=> hsub htr. + move/vm_truncate_valE_wdb: htr hsub; case: v => [b | z | len a| ws w | t i]; rewrite /truncatable. + 1-3: by move=> [-> ?] /subtypeEl -> /=. + + by move=> [ws' [-> ?? ]] /subtypeEl [sz' [-> h1]] /=; rewrite hwsw /= orbT. + move=> [+ _]; apply subtype_trans. +Qed. + +Lemma value_uincl_vm_truncate v1 v2 ty: + value_uincl v1 v2 -> + value_uincl (vm_truncate_val ty v1) (vm_truncate_val ty v2). +Proof. + move=> /value_uinclE; case: v1 => [b->|z->|len a|ws w|t i] //. + + by move=> [a' ->];case: ty => //= ?; case:ifP. + + move=> [ws' [w2 [-> /andP[hle1 /eqP ->]]]]; case: ty => //= ws2. + case sw_allowed => /=. + + case: (boolP (ws' <= ws2)%CMP). + + by move=> /(cmp_le_trans hle1) -> /=; apply word_uincl_zero_ext. + move=> hle2. + case: (boolP (ws <= ws2)%CMP) => hle3 /=. + + by rewrite -(zero_extend_idem _ hle3); apply word_uincl_zero_ext. + by rewrite zero_extend_idem //; apply cmp_lt_le; rewrite -cmp_nle_lt. + case: (boolP (ws2 <= ws)%CMP). + + move=> hle2; rewrite (cmp_le_trans hle2 hle1). + case: ifPn. + + move=> /(cmp_le_antisym hle2) ?; subst ws2. + by case: ifPn => //= ?; apply word_uincl_zero_ext. + move=> ?; rewrite zero_extend_idem //; case:ifPn => //= ?; apply word_uincl_zero_ext. + by apply: cmp_le_trans hle1. + by move=> ?; case:ifP => // ?; case:ifP => //=. + move=> /= ?; apply compat_value_uincl_undef; apply vm_truncate_val_compat. +Qed. + +Lemma compat_vm_truncate_val t1 t2 v1 v2 : + compat_type sw_allowed t1 t2 -> + value_uincl v1 v2 -> + value_uincl (vm_truncate_val t1 v1) (vm_truncate_val t2 v2). +Proof. + case: (boolP sw_allowed) => /=; last by move=> _ /eqP ->; apply value_uincl_vm_truncate. + move=> hsw. + case: t1 => [||len|ws1] /subtypeEl. + 1-3: by move=> ->; apply value_uincl_vm_truncate. + move=> [ws2 [-> hle]]. + case: v1 => [b|z|len1 a1|ws1' w1|t i] /value_uinclE. + 1-2: by move=> -> /=. + + by move=> [? -> ?] /=. + + move=> [ws2' [w2 [-> /andP [hle' /eqP ->]]]] /=. + rewrite hsw /=; case: ifPn => h1; case: ifPn => h2 //=. + + by apply word_uincl_zero_ext. + + have hle_ := cmp_le_trans h1 hle; rewrite -(zero_extend_idem _ hle_). + by apply word_uincl_zero_ext. + + rewrite cmp_nle_lt in h1; have h1_ := cmp_lt_le h1; rewrite zero_extend_idem //. + by apply word_uincl_zero_ext; apply: cmp_le_trans hle'. + rewrite cmp_nle_lt in h1; have h1_ := cmp_lt_le h1; rewrite zero_extend_idem //. + by rewrite -(zero_extend_idem _ hle); apply word_uincl_zero_ext. + move=> /=; move/or3P: i => [] /eqP ->; case: v2 => //= > _. + by rewrite hsw /=; case: ifP => /=. +Qed. + +Lemma truncatable_subtype (wdb : bool) ty v1 v2 : + (wdb -> ~sw_allowed -> is_sword ty -> ~is_defined v1 -> subtype ty (type_of_val v2)) -> + truncatable wdb ty v1 -> + subtype (type_of_val v1) (type_of_val v2) -> + truncatable wdb ty v2. +Proof. + move=> + /vm_truncate_valE_wdb; case: v1 => [b | i | p t | ws w | t ht]; rewrite /truncatable. + 1,2: by move=> _ [-> _] /subtypeEl /type_of_valI [|[?]]->. + + by move=> _ [-> _] /subtypeEl /type_of_valI [? ->] //=. + + move=> _ [ws' [? h _]] /=; subst ty; case: v2 => // ws'' w' /= hle. + + by case: wdb h => //=; case: sw_allowed => //= h; apply:cmp_le_trans h hle. + by move/or3P:w' hle => []/eqP -> //=. + move=> h [hsub _] /= /subtypeEl. + rewrite -(@undef_addr_eq t _ ht) in h; last by apply is_undef_undef_t. + move/or3P:ht hsub h => []/eqP -> //=. + 1,2: by move=> /eqP <- _ /type_of_valI [|[?]]->. + case: ty => // w _ h [ws [/type_of_valI]] [|[w']] ?; subst v2 => //= _. + by case: wdb h => //; case: sw_allowed => //=; apply. +Qed. + +Lemma vm_truncate_val_uincl (wdb : bool) v1 v2 ty: + (wdb -> ~sw_allowed -> is_sword ty -> ~is_defined v1 -> subtype ty (type_of_val v2)) -> + truncatable wdb ty v1 -> + value_uincl v1 v2 -> + truncatable wdb ty v2 /\ value_uincl (vm_truncate_val ty v1) (vm_truncate_val ty v2). +Proof. + move=> h htr hu; split. + apply (truncatable_subtype h htr (value_uincl_subtype hu)). + apply: value_uincl_vm_truncate hu. +Qed. + +Lemma compat_truncate_uincl wdb t1 t2 v1 v2: + compat_type sw_allowed t1 t2 -> + truncatable wdb t1 v1 -> + value_uincl v1 v2 -> + DB wdb v1 -> + [/\ truncatable wdb t2 v2, + value_uincl (vm_truncate_val t1 v1) (vm_truncate_val t2 v2) & + DB wdb v2]. +Proof. + move=> hc htr1 hu hdb. + have [|??]:= vm_truncate_val_uincl _ htr1 hu. + + move=> /eqP/eqP ? /negP/negbTE hsw hword hndef; subst wdb. + apply: subtype_trans (value_uincl_subtype hu). + by apply vm_truncate_val_subtype => //; rewrite hsw. + split. + + by apply (compat_truncatable hc). + + by apply compat_vm_truncate_val. + by apply: value_uincl_DB hu hdb. +Qed. + +Lemma vm_truncate_val_undef t : vm_truncate_val t (undef_addr t) = undef_addr t. +Proof. by case: t => //= p; rewrite eqxx. Qed. + +Lemma compat_val_vm_truncate_val t v : + compat_val t v -> vm_truncate_val t v = v. +Proof. + move=> /compat_valE; case: v => [b ->|z ->|len a ->|ws w [ws' -> h]|t' i htt'] //=. + + by rewrite eqxx. + + case: sw_allowed h => [h1 | ?] /=. + + by rewrite h1. + by subst ws'; rewrite cmp_le_refl. + apply undef_addr_eq. + by (case/or3P: i htt' => /eqP -> /subtypeEl) => [-> | -> | [? [-> _]]]. +Qed. + +End Section. + +(* ----------------------------------------------------------- *) + +Module Type VM. + + Parameter t : forall {wsw:WithSubWord}, Type. + + Parameter init : forall {wsw:WithSubWord}, t. + + Parameter get : forall {wsw:WithSubWord}, t -> var -> value. + + Parameter set : forall {wsw:WithSubWord}, t -> var -> value -> t. + + Parameter initP : forall {wsw:WithSubWord} x, + get init x = undef_addr (vtype x). + + Parameter getP : forall {wsw:WithSubWord} vm x, + compat_val (vtype x) (get vm x). + + Parameter setP : forall {wsw:WithSubWord} vm x v y, + get (set vm x v) y = if x == y then vm_truncate_val (vtype x) v else get vm y. + + Parameter setP_eq : forall {wsw:WithSubWord} vm x v, get (set vm x v) x = vm_truncate_val (vtype x) v. + + Parameter setP_neq : forall {wsw:WithSubWord} vm x v y, x != y -> get (set vm x v) y = get vm y. + +End VM. + +Module Vm : VM. + Section Section. + + Context {wsw: WithSubWord}. + + Definition wf (data: Mvar.t value) := + forall x v, Mvar.get data x = Some v -> compat_val (vtype x) v. + + Record t_ := { data :> Mvar.t value; prop : wf data }. + Definition t := t_. + + Lemma init_prop : wf (Mvar.empty value). + Proof. by move=> x v; rewrite Mvar.get0. Qed. + + Definition init := {| prop := init_prop |}. + + Definition get (vm:t) (x:var) := odflt (undef_addr (vtype x)) (Mvar.get vm x). + + Lemma set_prop (vm:t) x v : wf (Mvar.set vm x (vm_truncate_val (vtype x) v)). + Proof. + move=> y vy; rewrite Mvar.setP; case: eqP => [<- [<-] | _ /prop //]. + apply vm_truncate_val_compat. + Qed. + + Definition set (vm:t) (x:var) v := + {| data := Mvar.set vm x (vm_truncate_val (vtype x) v); prop := @set_prop vm x v |}. + + Lemma initP x : get init x = undef_addr (vtype x). + Proof. done. Qed. + + Lemma getP vm x : compat_val (vtype x) (get vm x). + Proof. rewrite /get; case h : Mvar.get => [ v | ] /=;[apply: prop h | apply compat_val_undef_addr]. Qed. + + Lemma setP vm x v y : + get (set vm x v) y = if x == y then vm_truncate_val (vtype x) v else get vm y. + Proof. by rewrite /get /set Mvar.setP; case: eqP => [<- | hne]. Qed. + + Lemma setP_eq vm x v : get (set vm x v) x = vm_truncate_val (vtype x) v. + Proof. by rewrite setP eqxx. Qed. + + Lemma setP_neq vm x v y : x != y -> get (set vm x v) y = get vm y. + Proof. by rewrite setP => /negbTE ->. Qed. + + End Section. + +End Vm. + +Declare Scope vm_scope. +Delimit Scope vm_scope with vm. +Notation "vm .[ x ]" := (@Vm.get _ vm x) : vm_scope. +Notation "vm .[ x <- v ]" := (@Vm.set _ vm x v) : vm_scope. +Open Scope vm_scope. + + +Section GET_SET. + +Context {wsw: WithSubWord}. + +Lemma vm_truncate_val_get x vm : + vm_truncate_val (vtype x) vm.[x] = vm.[x]. +Proof. apply/compat_val_vm_truncate_val/Vm.getP. Qed. + +Lemma getP_subtype vm x : subtype (type_of_val vm.[x]) (vtype x). +Proof. apply/compat_type_subtype/Vm.getP. Qed. + +Lemma subtype_undef_get vm x : + subtype (undef_t (vtype x)) (type_of_val vm.[x]). +Proof. + have /compat_type_undef_t <- := Vm.getP vm x. + apply undef_t_subtype. +Qed. + +Definition set_var wdb vm x v := + Let _ := assert (DB wdb v) ErrAddrUndef in + Let _ := assert (truncatable wdb (vtype x) v) ErrType in + ok vm.[x <- v]. + +(* Ensure that the variable is defined *) +Definition get_var wdb vm x := + let v := vm.[x]%vm in + Let _ := assert (~~wdb || is_defined v) ErrAddrUndef in + ok v. + +Definition vm_initialized_on vm : seq var → Prop := + all (λ x, is_ok (get_var true vm x >>= of_val (vtype x))). + +Lemma set_varP wdb vm x v vm' : + set_var wdb vm x v = ok vm' <-> [/\ DB wdb v, truncatable wdb (vtype x) v & vm' = vm.[x <- v]]. +Proof. by rewrite /set_var; split => [ | [-> -> -> //]]; t_xrbindP. Qed. + +Lemma set_var_truncate wdb x v : + DB wdb v -> truncatable wdb (vtype x) v -> + forall vm, set_var wdb vm x v = ok vm.[x <- v]. +Proof. by rewrite /set_var => -> ->. Qed. + +Lemma set_var_eq_type wdb x v: + DB wdb v -> type_of_val v = vtype x -> + forall vm, set_var wdb vm x v = ok vm.[x <- v]. +Proof. move => h1 h2; apply set_var_truncate => //; rewrite -h2; apply truncatable_type_of. Qed. + +Lemma set_varDB wdb vm x v vm' : set_var wdb vm x v = ok vm' -> DB wdb v. +Proof. by move=> /set_varP []. Qed. + +Lemma get_varP wdb vm x v : get_var wdb vm x = ok v -> + [/\ v = vm.[x], ~~wdb || is_defined v & compat_val (vtype x) v]. +Proof. rewrite/get_var;t_xrbindP => ? <-; split => //; apply Vm.getP. Qed. + +Lemma get_var_compat wdb vm x v : get_var wdb vm x = ok v -> + (~~wdb || is_defined v) /\ compat_val (vtype x) v. +Proof. by move=>/get_varP []. Qed. + +Lemma get_var_undef vm x v ty h : + get_var true vm x = ok v -> v <> Vundef ty h. +Proof. by move=> /get_var_compat [] * ?; subst. Qed. + +Lemma get_varI vm x v : get_var true vm x = ok v -> + match v with + | Vbool _ => vtype x = sbool + | Vint _ => vtype x = sint + | Varr len _ => vtype x = sarr len + | Vword ws _ => + exists2 ws', vtype x = sword ws' & + if sw_allowed then ((ws <= ws')%CMP:Prop) else ws = ws' + | Vundef ty' _ => False + end. +Proof. by move=> /get_var_compat [] + /compat_valE; case: v. Qed. + +Lemma get_varE vm x v : get_var true vm x = ok v -> + match vtype x with + | sbool => exists b, v = Vbool b + | sint => exists i, v = Vint i + | sarr len => exists t, v = @Varr len t + | sword ws => + exists ws', exists2 w:word ws', v = Vword w & + if sw_allowed then ((ws' <= ws)%CMP:Prop) else ws = ws' + end. +Proof. + by move=> /get_var_compat [] h1 /compat_valEl h2; case:vtype h2 h1 => [ | | len | ws] // [->|]. +Qed. + +Lemma type_of_get_var wdb x vm v : + get_var wdb vm x = ok v -> + subtype (type_of_val v) (x.(vtype)). +Proof. + by move=> /get_var_compat [] _; rewrite /compat_val /compat_type; case: ifP => // _ /eqP <-. +Qed. + +(* We have a more precise result in the non-word cases. *) +Lemma type_of_get_var_not_word vm x v : + (sw_allowed -> ~ is_sword x.(vtype)) -> + get_var true vm x = ok v -> + type_of_val v = x.(vtype). +Proof. + move=> h /get_var_compat [] /= hdb; rewrite /compat_val /compat_type hdb orbF. + case: ifP => //; last by move=> _ /eqP. + by move=> /h; case: vtype => //= [||len] _ /subtypeE. +Qed. + +Lemma get_word_uincl_eq vm x ws (w:word ws) : + value_uincl (Vword w) vm.[x] -> + subtype (vtype x) (sword ws) -> + vm.[x] = Vword w. +Proof. + move => /value_uinclE [ws' [w' [heq ]]]; have := getP_subtype vm x; rewrite heq. + move=> /subtypeEl [ws''] [-> h1] /andP [h2 /eqP ->] /= h3. + by have ? := cmp_le_antisym (cmp_le_trans h1 h3) h2; subst ws'; rewrite zero_extend_u. +Qed. + +End GET_SET. + +(* Attempt to simplify goals of the form [vm.[y0 <- z0]...[yn <- zn].[x]]. *) +Ltac t_vm_get := + repeat ( + rewrite Vm.setP_eq + || (rewrite Vm.setP_neq; last (apply/eqP; by [|apply/nesym])) + ). + +(* ----------------------------------------------------------------------- *) +(* Generic relation over varmap *) + +Section REL. + + Context {wsw1 wsw2 : WithSubWord}. + + Section Section. + + Context (R:value -> value -> Prop). + + Definition vm_rel (P : var -> Prop) (vm1 : @Vm.t wsw1) (vm2 : @Vm.t wsw2) := + forall x, P x -> R (Vm.get vm1 x) (Vm.get vm2 x). + + Lemma vm_rel_set (P : var -> Prop) vm1 vm2 x v1 v2 : + (P x -> R (vm_truncate_val (wsw:=wsw1) (vtype x) v1) (vm_truncate_val (wsw:=wsw2) (vtype x) v2)) -> + vm_rel (fun z => x <> z /\ P z) vm1 vm2 -> + vm_rel P vm1.[x <- v1] vm2.[x <- v2]. + Proof. move=> h hu y hy; rewrite !Vm.setP; case: eqP => heq; subst; auto. Qed. + + Lemma vm_rel_set_r (P : var -> Prop) vm1 vm2 x v2 : + (P x -> R vm1.[x] (vm_truncate_val (wsw:=wsw2) (vtype x) v2)) -> + vm_rel (fun z => x <> z /\ P z) vm1 vm2 -> + vm_rel P vm1 (vm2.[x <- v2]). + Proof. move=> h hu y hy; rewrite !Vm.setP; case: eqP => heq; subst; auto. Qed. + + Lemma vm_rel_set_l (P : var -> Prop) vm1 vm2 x v1 : + (P x -> R (vm_truncate_val (wsw:=wsw1) (vtype x) v1) vm2.[x]) -> + vm_rel (fun z => x <> z /\ P z) vm1 vm2 -> + vm_rel P vm1.[x <- v1] vm2. + Proof. move=> h hu y hy; rewrite !Vm.setP; case: eqP => heq; subst; auto. Qed. + + End Section. + + #[export] Instance vm_rel_impl : + Proper (subrelation ==> + pointwise_lifting (Basics.flip Basics.impl) (Tcons var Tnil) ==> + @eq Vm.t ==> @eq Vm.t ==> Basics.impl) vm_rel. + Proof. by move=> R1 R2 hR P1 P2 hP vm1 ? <- vm2 ? <- h x hx; apply/hR/h/hP. Qed. + + #[export] Instance vm_rel_m : + Proper (relation_equivalence ==> + pointwise_lifting iff (Tcons var Tnil) ==> + @eq Vm.t ==> @eq Vm.t ==> iff) vm_rel. + Proof. + move=> R1 R2 hR P1 P2 hP vm1 ? <- vm2 ? <-; split; apply vm_rel_impl => //. + 1,3: by move=> ??;apply hR. + 1,2: by move=> x /=; case: (hP x). + Qed. + + Definition vm_eq (vm1:Vm.t (wsw:=wsw1)) (vm2:Vm.t (wsw:=wsw2)) := + forall x, vm1.[x] = vm2.[x]. + + Definition eq_on (X:Sv.t) := vm_rel (@eq value) (fun x => Sv.In x X). + Definition eq_ex (X:Sv.t) := vm_rel (@eq value) (fun x => ~Sv.In x X). + + Definition vm_uincl (vm1:Vm.t (wsw:=wsw1)) (vm2:Vm.t (wsw:=wsw2)) := + forall x, value_uincl vm1.[x] vm2.[x]. + + Definition uincl_on (X:Sv.t) := vm_rel value_uincl (fun x => Sv.In x X). + Definition uincl_ex (X:Sv.t) := vm_rel value_uincl (fun x => ~Sv.In x X). + + #[export] Instance eq_on_impl : + Proper (Basics.flip Sv.Subset ==> @eq Vm.t ==> @eq Vm.t ==> Basics.impl) eq_on. + Proof. by move=> s1 s2 hS; apply vm_rel_impl. Qed. + + #[export] Instance eq_on_m : + Proper (Sv.Equal ==> @eq Vm.t ==> @eq Vm.t ==> iff) eq_on. + Proof. by move=> s1 s2 hS; apply vm_rel_m. Qed. + + #[export] Instance eq_ex_impl : + Proper (Sv.Subset ==> @eq Vm.t ==> @eq Vm.t ==> Basics.impl) eq_ex. + Proof. by move=> s1 s2 hS; apply vm_rel_impl => // x hnx hx; apply/hnx/hS. Qed. + + #[export] Instance eq_ex_m : + Proper (Sv.Equal ==> @eq Vm.t ==> @eq Vm.t ==> iff) eq_ex. + Proof. by move=> s1 s2 hS; apply vm_rel_m => // x; rewrite hS. Qed. + + #[export] Instance uincl_on_impl : + Proper (Basics.flip Sv.Subset ==> @eq Vm.t ==> @eq Vm.t ==> Basics.impl) uincl_on. + Proof. by move=> s1 s2 hS; apply vm_rel_impl. Qed. + + #[export] Instance uincl_on_m : + Proper (Sv.Equal ==> @eq Vm.t ==> @eq Vm.t ==> iff) uincl_on. + Proof. by move=> s1 s2 hS; apply vm_rel_m. Qed. + + #[export] Instance uincl_ex_impl : + Proper (Sv.Subset ==> @eq Vm.t ==> @eq Vm.t ==> Basics.impl) uincl_ex. + Proof. by move=> s1 s2 hS; apply vm_rel_impl => // x hnx hx; apply/hnx/hS. Qed. + + #[export] Instance uincl_ex_m : + Proper (Sv.Equal ==> @eq Vm.t ==> @eq Vm.t ==> iff) uincl_ex. + Proof. by move=> s1 s2 hS; apply vm_rel_m => // x; rewrite hS. Qed. + + Lemma vm_eq_vm_rel vm1 vm2 : vm_eq vm1 vm2 <-> vm_rel (@eq value) (fun _ => True) vm1 vm2. + Proof. by split => [h x _ | h x]; apply h. Qed. + + Lemma vm_uincl_vm_rel vm1 vm2 : vm_uincl vm1 vm2 <-> vm_rel value_uincl (fun _ => True) vm1 vm2. + Proof. by split => [h x _ | h x]; apply h. Qed. + +End REL. + +Notation "vm1 '=1' vm2" := (vm_eq vm1 vm2) + (at level 70, vm2 at next level) : vm_scope. + +Notation "vm1 '=[' s ']' vm2" := (eq_on s vm1 vm2) + (at level 70, vm2 at next level, + format "'[hv ' vm1 =[ s ] '/' vm2 ']'") : vm_scope. + +Notation "vm1 '=[\' s ']' vm2" := (eq_ex s vm1 vm2) + (at level 70, vm2 at next level, + format "'[hv ' vm1 =[\ s ] '/' vm2 ']'") : vm_scope. + +Notation "vm1 '<=1' vm2" := (vm_uincl vm1 vm2) + (at level 70, vm2 at next level, + format "'[hv ' vm1 <=1 '/' vm2 ']'") : vm_scope. + +Notation "vm1 '<=[' s ']' vm2" := (uincl_on s vm1 vm2) + (at level 70, vm2 at next level, + format "'[hv ' vm1 <=[ s ] '/' vm2 ']'") : vm_scope. + +Notation "vm1 '<=[\' s ']' vm2" := (uincl_ex s vm1 vm2) + (at level 70, vm2 at next level, + format "'[hv ' vm1 <=[\ s ] '/' vm2 ']'") : vm_scope. + +Section REL_EQUIV. + Context {wsw : WithSubWord}. + + Lemma vm_rel_refl R P : Reflexive R -> Reflexive (vm_rel R P). + Proof. by move=> h x v _. Qed. + + Lemma vm_rel_sym R P : Symmetric R -> Symmetric (vm_rel R P). + Proof. by move=> h x y hxy v hv; apply/h/hxy. Qed. + + Lemma vm_rel_trans R P : Transitive R -> Transitive (vm_rel R P). + Proof. move=> h x y z hxy hyz v hv; apply: h (hxy v hv) (hyz v hv). Qed. + + Lemma vm_relI R (P1 P2 : var -> Prop) vm1 vm2 : + (forall x, P1 x -> P2 x) -> + vm_rel R P2 vm1 vm2 -> vm_rel R P1 vm1 vm2. + Proof. by move=> h hvm v /h hv; apply hvm. Qed. + + #[export]Instance equiv_vm_rel R P : Equivalence R -> Equivalence (vm_rel R P). + Proof. + by constructor; [apply: vm_rel_refl | apply: vm_rel_sym | apply: vm_rel_trans]. + Qed. + + #[export]Instance equiv_vm_eq : Equivalence vm_eq. + Proof. by constructor => > // => [h1 x | h1 h2 x]; rewrite h1 ?h2. Qed. + + #[export]Instance equiv_eq_on s : Equivalence (eq_on s). + Proof. apply equiv_vm_rel; apply eq_equivalence. Qed. + + #[export]Instance equiv_eq_ex s : Equivalence (eq_ex s). + Proof. apply equiv_vm_rel; apply eq_equivalence. Qed. + + #[export]Instance po_vm_rel R P: PreOrder R -> PreOrder (vm_rel R P). + Proof. by constructor; [apply: vm_rel_refl | apply: vm_rel_trans]. Qed. + + #[export]Instance po_value_uincl : PreOrder value_uincl. + Proof. constructor => // ???; apply value_uincl_trans. Qed. + + #[export]Instance po_vm_uincl : PreOrder vm_uincl. + Proof. + constructor => [ vm1 // | vm1 vm2 vm3]. + rewrite !vm_uincl_vm_rel; apply vm_rel_trans => ???; apply value_uincl_trans. + Qed. + + #[export]Instance po_uincl_on s : PreOrder (uincl_on s). + Proof. apply po_vm_rel; apply po_value_uincl. Qed. + + #[export]Instance po_uincl_ex s : PreOrder (uincl_ex s). + Proof. apply po_vm_rel; apply po_value_uincl. Qed. + + Lemma vm_uincl_refl vm : vm <=1 vm. + Proof. done. Qed. + + Lemma vm_uinclT vm2 vm1 vm3 : vm1 <=1 vm2 -> vm2 <=1 vm3 -> vm1 <=1 vm3. + Proof. rewrite !vm_uincl_vm_rel; apply vm_rel_trans => ???; apply: value_uincl_trans. Qed. + + Lemma eq_on_refl s vm : vm =[s] vm. + Proof. by apply vm_rel_refl. Qed. + + Lemma eq_onT vm2 vm1 vm3 s: + vm1 =[s] vm2 -> vm2 =[s] vm3 -> vm1 =[s] vm3. + Proof. by apply vm_rel_trans => > -> ->. Qed. + + Lemma eq_onS s vm1 vm2 : vm1 =[s] vm2 -> vm2 =[s] vm1. + Proof. by apply vm_rel_sym. Qed. + + Lemma eq_onI s1 s2 vm1 vm2 : Sv.Subset s1 s2 -> vm1 =[s2] vm2 -> vm1 =[s1] vm2. + Proof. move=> h1; apply vm_relI; SvD.fsetdec. Qed. + + Lemma eq_ex_refl s vm : vm =[\s] vm. + Proof. by apply vm_rel_refl. Qed. + + Lemma eq_exT vm2 vm1 vm3 s: + vm1 =[\s] vm2 -> vm2 =[\s] vm3 -> vm1 =[\s] vm3. + Proof. by apply vm_rel_trans => > -> ->. Qed. + + Lemma eq_exS s vm1 vm2 : vm1 =[\s] vm2 -> vm2 =[\s] vm1. + Proof. by apply vm_rel_sym. Qed. + + Lemma eq_exI s1 s2 vm1 vm2 : Sv.Subset s2 s1 -> vm1 =[\s2] vm2 -> vm1 =[\s1] vm2. + Proof. move=> h1; apply vm_relI; SvD.fsetdec. Qed. + + Lemma uincl_on_refl vm s : vm <=[s] vm. + Proof. done. Qed. + + Lemma uincl_onT vm2 vm1 vm3 s: + vm1 <=[s] vm2 -> vm2 <=[s] vm3 -> vm1 <=[s] vm3. + Proof. apply vm_rel_trans => ???; apply value_uincl_trans. Qed. + + Lemma uincl_onI s1 s2 vm1 vm2 : Sv.Subset s1 s2 -> vm1 <=[s2] vm2 -> vm1 <=[s1] vm2. + Proof. move=> h1; apply vm_relI; SvD.fsetdec. Qed. + + Lemma uincl_ex_refl s vm : vm <=[\s] vm. + Proof. apply vm_rel_refl => ?; apply value_uincl_refl. Qed. + + Lemma uincl_exT vm2 vm1 vm3 s: + vm1 <=[\s] vm2 -> vm2 <=[\s] vm3 -> vm1 <=[\s] vm3. + Proof. apply vm_rel_trans => ???; apply value_uincl_trans. Qed. + + Lemma uincl_exI s1 s2 vm1 vm2 : + Sv.Subset s2 s1 -> vm1 <=[\s2] vm2 -> vm1 <=[\s1] vm2. + Proof. move=> h1; apply vm_relI; SvD.fsetdec. Qed. + + Lemma eq_ex_union s1 s2 vm1 vm2 : + vm1 =[\s1] vm2 -> vm1 =[\Sv.union s1 s2] vm2. + Proof. apply: eq_exI; SvD.fsetdec. Qed. + + Lemma eq_exTI s1 s2 vm1 vm2 vm3 : + vm1 =[\s1] vm2 -> + vm2 =[\s2] vm3 -> + vm1 =[\Sv.union s1 s2] vm3. + Proof. + move => h12 h23; apply: (@eq_exT vm2); apply: eq_exI; eauto; SvD.fsetdec. + Qed. + + Lemma eq_ex_eq_on x y z e o : + x =[\e] y → + z =[o] y → + x =[Sv.diff o e] z. + Proof. move => he ho j hj; rewrite he ?ho; SvD.fsetdec. Qed. + + Lemma vm_rel_set_var (wdb:bool) (P : var -> Prop) vm1 vm1' vm2 x v1 v2 : + value_uincl v1 v2 -> + vm_rel value_uincl (fun z => x <> z /\ P z) vm1 vm2 -> + set_var wdb vm1 x v1 = ok vm1' -> + set_var wdb vm2 x v2 = ok vm2.[x<-v2] /\ vm_rel value_uincl P vm1' vm2.[x<-v2]. + Proof. + move=> hu hvm /set_varP [hdb htr1 ->]. + split. + rewrite (set_var_truncate (value_uincl_DB hu hdb)) //. + + apply: truncatable_subtype (htr1) (value_uincl_subtype hu). + case: wdb hdb htr1 => //=; rewrite /DB /= => /orP [-> // | /eqP /type_of_valI]. + by move=> [-> /eqP <- | [b ->]]. + move=> z; rewrite !Vm.setP; case: eqP => // ??; last by apply hvm. + by apply value_uincl_vm_truncate. + Qed. + + Lemma vm_uincl_set vm1 vm2 x v1 v2 : + value_uincl (vm_truncate_val (vtype x) v1) (vm_truncate_val (vtype x) v2) -> + vm1 <=1 vm2 -> + vm1.[x <- v1] <=1 vm2.[x <- v2]. + Proof. by rewrite !vm_uincl_vm_rel => hvu hu; apply vm_rel_set => //; apply: vm_relI hu. Qed. + + Lemma vm_uincl_set_l vm1 vm2 x v : + value_uincl (vm_truncate_val (vtype x) v) vm2.[x] -> + vm1 <=1 vm2 -> + vm1.[x <- v] <=1 vm2. + Proof. by rewrite !vm_uincl_vm_rel => hvu hu; apply vm_rel_set_l => //; apply: vm_relI hu. Qed. + + Lemma vm_uincl_set_r vm1 vm2 x v : + value_uincl vm1.[x] (vm_truncate_val (vtype x) v) -> + vm1 <=1 vm2 -> + vm1 <=1 vm2.[x <- v]. + Proof. by rewrite !vm_uincl_vm_rel => hvu hu; apply vm_rel_set_r => //; apply: vm_relI hu. Qed. + + Lemma vm_uincl_set_var wdb vm1 vm1' vm2 x v1 v2 : + value_uincl v1 v2 -> + vm1 <=1 vm2 -> + set_var wdb vm1 x v1 = ok vm1' -> + set_var wdb vm2 x v2 = ok vm2.[x<-v2] /\ vm1' <=1 vm2.[x<-v2]. + Proof. + move=> h1 /vm_uincl_vm_rel h2 h3. + have /(_ (fun _ => True) vm2) [|? /vm_uincl_vm_rel //]:= vm_rel_set_var h1 _ h3. + by apply: vm_relI h2. + Qed. + + Lemma uincl_on_set X vm1 vm2 x v1 v2: + (Sv.In x X -> value_uincl (vm_truncate_val (vtype x) v1) (vm_truncate_val (vtype x) v2)) -> + vm1 <=[Sv.remove x X] vm2 -> + vm1.[x <- v1] <=[X] vm2.[x <- v2]. + Proof. move=> hvu hu; apply vm_rel_set => //; apply: vm_relI hu; SvD.fsetdec. Qed. + + Lemma uincl_on_set_l X vm1 vm2 x v : + (Sv.In x X -> value_uincl (vm_truncate_val (vtype x) v) vm2.[x]) -> + vm1 <=[Sv.remove x X] vm2 -> + vm1.[x <- v] <=[X] vm2. + Proof. move=> hvu hu; apply vm_rel_set_l => //; apply: vm_relI hu; SvD.fsetdec. Qed. + + Lemma uincl_on_set_r X vm1 vm2 x v : + (Sv.In x X ->value_uincl vm1.[x] (vm_truncate_val (vtype x) v)) -> + vm1 <=[Sv.remove x X] vm2 -> + vm1 <=[X] vm2.[x <- v]. + Proof. by move=> hvu hu; apply vm_rel_set_r => //; apply: vm_relI hu; SvD.fsetdec. Qed. + + Lemma uincl_on_set_var (wdb:bool) s vm1 vm1' vm2 x v1 v2 : + value_uincl v1 v2 -> + vm1 <=[Sv.remove x s] vm2 -> + set_var wdb vm1 x v1 = ok vm1' -> + set_var wdb vm2 x v2 = ok vm2.[x<-v2] /\ vm1' <=[s] vm2.[x<-v2]. + Proof. move=> h1 h2; apply vm_rel_set_var => // z hz; apply h2; SvD.fsetdec. Qed. + + Lemma eq_ex_set s vm1 vm2 x v1 v2 : + (~Sv.In x s -> vm_truncate_val (vtype x) v1 = vm_truncate_val (vtype x) v2) -> + vm1 =[\Sv.add x s] vm2 -> + vm1.[x<-v1] =[\ s] vm2.[x<-v2]. + Proof. move=> h1 h2; apply vm_rel_set => // z hz; apply h2; SvD.fsetdec. Qed. + + Lemma eq_ex_set_r s vm1 vm2 x v : + (~Sv.In x s -> vm1.[x] = vm_truncate_val (vtype x) v) -> + vm1 =[\Sv.add x s] vm2 -> + vm1 =[\ s] vm2.[x<-v]. + Proof. move=> h1 h2; apply vm_rel_set_r => // z hz; apply h2; SvD.fsetdec. Qed. + + Lemma eq_ex_set_l s vm1 vm2 x v : + (~Sv.In x s -> vm_truncate_val (vtype x) v = vm2.[x]) -> + vm1 =[\Sv.add x s] vm2 -> + vm1.[x<-v] =[\ s] vm2. + Proof. move=> h1 h2; apply vm_rel_set_l => // z hz; apply h2; SvD.fsetdec. Qed. + + Lemma uincl_ex_set s vm1 vm2 x v1 v2 : + (~Sv.In x s -> value_uincl (vm_truncate_val (vtype x) v1) (vm_truncate_val (vtype x) v2)) -> + vm1 <=[\Sv.add x s] vm2 -> + vm1.[x<-v1] <=[\ s] vm2.[x<-v2]. + Proof. move=> h1 h2; apply vm_rel_set => // z hz; apply h2; SvD.fsetdec. Qed. + + Lemma uincl_ex_set_r s vm1 vm2 x v : + (~Sv.In x s -> value_uincl vm1.[x] (vm_truncate_val (vtype x) v)) -> + vm1 <=[\Sv.add x s] vm2 -> + vm1 <=[\ s] vm2.[x<-v]. + Proof. move=> h1 h2; apply vm_rel_set_r => // z hz; apply h2; SvD.fsetdec. Qed. + + Lemma uincl_ex_set_l s vm1 vm2 x v : + (~Sv.In x s -> value_uincl (vm_truncate_val (vtype x) v) vm2.[x]) -> + vm1 <=[\Sv.add x s] vm2 -> + vm1.[x<-v] <=[\ s] vm2. + Proof. move=> h1 h2; apply vm_rel_set_l => // z hz; apply h2; SvD.fsetdec. Qed. + + Lemma uincl_ex_set_var (wdb:bool) s vm1 vm1' vm2 x v1 v2 : + value_uincl v1 v2 -> + vm1 <=[\s] vm2 -> + set_var wdb vm1 x v1 = ok vm1' -> + set_var wdb vm2 x v2 = ok vm2.[x<-v2] /\ vm1' <=[\ Sv.remove x s] vm2.[x<-v2]. + Proof. move=> h1 h2; apply vm_rel_set_var => // ??; apply h2; SvD.fsetdec. Qed. + + Lemma uincl_on_vm_uincl vm1 vm2 vm1' vm2' d : + vm1 <=1 vm2 → + vm1' <=[d] vm2' → + vm1 =[\d] vm1'→ + vm2 =[\d] vm2' → + vm1' <=1 vm2'. + Proof. + move => out on t1 t2 x. + case: (Sv_memP x d); first exact: on. + by move => hx; rewrite -!(t1, t2) //; apply out. + Qed. + + Lemma eq_on_eq_vm vm1 vm2 vm1' vm2' d : + vm1 =1 vm2 → + vm1' =[d] vm2' → + vm1 =[\d] vm1'→ + vm2 =[\d] vm2' → + vm1' =1 vm2'. + Proof. + move => out on t1 t2 x. + case: (Sv_memP x d); first exact: on. + by move => hx; rewrite -!(t1, t2) //; apply out. + Qed. + + Lemma eq_on_union vm1 vm2 vm1' vm2' X Y : + vm1 =[X] vm2 → + vm1' =[Y] vm2' → + vm1 =[\Y] vm1'→ + vm2 =[\Y] vm2' → + vm1' =[Sv.union Y X] vm2'. + Proof. + move => out on t1 t2 x hx. + case: (Sv_memP x Y); first exact: on. + move => hxY; rewrite -!(t1, t2) //; apply out; SvD.fsetdec. + Qed. + + Lemma uincl_on_union vm1 vm2 vm1' vm2' X Y : + vm1 <=[X] vm2 → + vm1' <=[Y] vm2' → + vm1 =[\Y] vm1'→ + vm2 =[\Y] vm2' → + vm1' <=[Sv.union Y X] vm2'. + Proof. + move => out on t1 t2 x hx. + case: (Sv_memP x Y); first exact: on. + move => hxY; rewrite -!(t1, t2) //; apply out; SvD.fsetdec. + Qed. + + Lemma set_var_eq_ex (wdb: bool) (x:var) v vm1 vm2 : + set_var wdb vm1 x v = ok vm2 -> + vm1 =[\ Sv.singleton x] vm2. + Proof. move=> /set_varP [??->] z hz; rewrite Vm.setP_neq //; apply/eqP; SvD.fsetdec. Qed. + + Lemma set_var_eq_on1 wdb x v vm1 vm2 vm1': + set_var wdb vm1 x v = ok vm2 -> + set_var wdb vm1' x v = ok vm1'.[x <- v] /\ vm2 =[Sv.singleton x] vm1'.[x <- v]. + Proof. + move=> /set_varP [hdb htr ->]; split; first by rewrite set_var_truncate. + move=> z hz; rewrite !Vm.setP; case: eqP => // hne; SvD.fsetdec. + Qed. + + Lemma set_var_eq_on wdb s x v vm1 vm2 vm1': + set_var wdb vm1 x v = ok vm2 -> + vm1 =[s] vm1' -> + set_var wdb vm1' x v = ok vm1'.[x <- v] /\ vm2 =[Sv.add x s] vm1'.[x <- v]. + Proof. + move=> /dup [] /(set_var_eq_on1 vm1') [hw2 h] hw1 hs. + split => //; rewrite SvP.MP.add_union_singleton. + apply: (eq_on_union hs h); apply: set_var_eq_ex; eauto. + Qed. + + Lemma get_var_uincl_at wdb x vm1 vm2 v1 : + (value_uincl vm1.[x] vm2.[x]) -> + get_var wdb vm1 x = ok v1 -> + exists2 v2, get_var wdb vm2 x = ok v2 & value_uincl v1 v2. + Proof. rewrite /get_var; t_xrbindP => hu /(value_uincl_defined hu) -> <- /=; eauto. Qed. + + Lemma get_var_uincl wdb x vm1 vm2 v1: + vm1 <=1 vm2 -> + get_var wdb vm1 x = ok v1 -> + exists2 v2, get_var wdb vm2 x = ok v2 & value_uincl v1 v2. + Proof. move => /(_ x); exact: get_var_uincl_at. Qed. + + Lemma eq_on_uincl_on X vm1 vm2 : vm1 =[X] vm2 -> vm1 <=[X] vm2. + Proof. by move=> H ? /H ->. Qed. + + Lemma eq_ex_uincl_ex X vm1 vm2: vm1 =[\X] vm2 -> vm1 <=[\X] vm2. + Proof. by move=> H ? /H ->. Qed. + + Lemma vm_uincl_uincl_on dom vm1 vm2 : + vm1 <=1 vm2 → + vm1 <=[dom] vm2. + Proof. by move => h x _; exact: h. Qed. + + Lemma vm_eq_eq_on dom vm1 vm2 : + vm1 =1 vm2 → + vm1 =[dom] vm2. + Proof. by move => h x _; exact: h. Qed. + + Lemma eq_on_empty vm1 vm2 : + vm1 =[Sv.empty] vm2. + Proof. by move => ?; SvD.fsetdec. Qed. + + Lemma uincl_on_empty vm1 vm2 : + vm1 <=[Sv.empty] vm2. + Proof. by move => ?; SvD.fsetdec. Qed. + + Hint Resolve eq_on_empty uincl_on_empty : core. + + Lemma uincl_on_union_and dom dom' vm1 vm2 : + vm1 <=[Sv.union dom dom'] vm2 ↔ + vm1 <=[dom] vm2 ∧ vm1 <=[dom'] vm2. + Proof. + split. + + by move => h; split => x hx; apply: h; SvD.fsetdec. + by case => h h' x /Sv.union_spec[]; [ exact: h | exact: h' ]. + Qed. + + Lemma vm_uincl_uincl_ex dom vm1 vm2 : + vm1 <=1 vm2 → + vm1 <=[\dom] vm2. + Proof. by move => h x _; exact: h. Qed. + + Instance uincl_ex_trans dom : Transitive (uincl_ex dom). + Proof. by move => x y z; apply: uincl_exT. Qed. + + Lemma uincl_ex_empty vm1 vm2 : + vm1 <=[\ Sv.empty ] vm2 ↔ vm_uincl vm1 vm2. + Proof. + split; last exact: vm_uincl_uincl_ex. + move => h x; apply/h; SvD.fsetdec. + Qed. + + Lemma eq_ex_disjoint_eq_on s s' x y : + x =[\s] y → + disjoint s s' → + x =[s'] y. + Proof. rewrite /disjoint /is_true Sv.is_empty_spec => h d r hr; apply: h; SvD.fsetdec. Qed. + + Lemma vm_uincl_init vm : Vm.init <=1 vm. + Proof. move=> z; rewrite Vm.initP; apply/compat_value_uincl_undef/Vm.getP. Qed. + + Lemma set_var_spec wdb x v vm1 vm2 vm1' : + set_var wdb vm1 x v = ok vm2 -> + exists vm2', [/\ set_var wdb vm1' x v = ok vm2', vm1' =[\ Sv.singleton x] vm2' & vm2'.[x] = vm2.[x] ]. + Proof. + move=> /set_varP [hdb htr ->]. + exists vm1'.[x <- v]; split. + + by rewrite set_var_truncate. + + by apply vm_rel_set_r => //; SvD.fsetdec. + by rewrite !Vm.setP_eq. + Qed. + +End REL_EQUIV. + +#[export] Hint Resolve vm_uincl_refl eq_on_refl eq_ex_refl uincl_on_refl uincl_ex_refl vm_uincl_init : core. +#[export] Hint Resolve eq_on_empty uincl_on_empty : core. +#[export] Hint Resolve truncatable_arr : core. + +#[export] Existing Instance vm_rel_impl. +#[export] Existing Instance vm_rel_m. +#[export] Existing Instance eq_on_impl. +#[export] Existing Instance eq_on_m. +#[export] Existing Instance eq_ex_impl. +#[export] Existing Instance eq_ex_m. +#[export] Existing Instance uincl_on_impl. +#[export] Existing Instance uincl_on_m. +#[export] Existing Instance uincl_ex_impl. +#[export] Existing Instance uincl_ex_m. +#[export] Existing Instance equiv_vm_rel. +#[export] Existing Instance equiv_vm_eq. +#[export] Existing Instance equiv_eq_on. +#[export] Existing Instance equiv_eq_ex. +#[export] Existing Instance po_vm_rel. +#[export] Existing Instance po_value_uincl. +#[export] Existing Instance po_vm_uincl. +#[export] Existing Instance po_uincl_on. +#[export] Existing Instance po_uincl_ex. +#[export] Existing Instance uincl_ex_trans. + +#[ global ]Arguments get_var {wsw} wdb vm%vm_scope x. +#[ global ]Arguments set_var {wsw} wdb vm%vm_scope x v. + diff --git a/proofs/lang/warray_.v b/proofs/lang/warray_.v index 59036d1ed..6989f5259 100644 --- a/proofs/lang/warray_.v +++ b/proofs/lang/warray_.v @@ -495,6 +495,40 @@ Module WArray. 0 <= p * mk_scale aa ws /\ p * mk_scale aa ws + arr_size ws len <= lena. Proof. by rewrite /set_sub; case: ifP => //; rewrite !zify. Qed. + Transparent arr_size. Opaque Z.mul ziota. + Lemma set_sub_get lena ws len (t: array lena) i (s: array (Z.to_pos (arr_size ws len))) t': + set_sub AAscale t i s = ok t' -> + forall j, + get AAscale ws t' j = + if ((i <=? j) && (j hget j. + have ht':= set_sub_get8 hget. + have := set_sub_bound hget. + have ltws := wsize_size_pos ws; rewrite /arr_size /mk_scale => hb. + have [{hb} h0i hilen'] : (0 <= i /\ i + len <= lena)%Z by Psatz.nia. + rewrite /get !readE !is_align_scale /=. + case: ifPn. + + move=> /andP[]/ZleP ? /ZltP ?. + have -> // : + mapM (λ k : Z, read t' (add ( j * wsize_size ws)%Z k) U8) (ziota 0 (wsize_size ws)) = + mapM (λ k : Z, read s (add ((j - i) * wsize_size ws)%Z k) U8) (ziota 0 (wsize_size ws)). + apply eq_mapM => k; rewrite in_ziota => /andP []/ZleP ? /ZltP ?. + rewrite ht' /= !WArray.addE. + case: ifPn => [ _ | /negP]; first by f_equal; ring. + elim; apply/andP; split; [apply/ZleP|apply/ZltP; rewrite /arr_size]; Psatz.nia. + move=> /negP hij. + have -> // : + mapM (λ k : Z, read t' (add (j * wsize_size ws)%Z k) U8) (ziota 0 (wsize_size ws)) = + mapM (λ k : Z, read t (add (j * wsize_size ws)%Z k) U8) (ziota 0 (wsize_size ws)). + apply eq_mapM => k; rewrite in_ziota => /andP []/ZleP ? /ZltP ?. + rewrite ht' /= !WArray.addE /arr_size. + case: ifPn => // /andP [] /ZleP ? /ZltP ?; elim hij. + apply/andP; split; [apply/ZleP|apply/ZltP]; Psatz.nia. + Qed. + Transparent Z.mul ziota. Opaque arr_size. + Lemma get_sub_data_get8 aa ws a len p k: Mz.get (get_sub_data aa ws len a p) k = let start := (p * mk_scale aa ws)%Z in @@ -563,6 +597,27 @@ Module WArray. by move=> k w; rewrite hr1 hr2; case: ifP => // [ ? /hget2| ? /hget1]. Qed. + Transparent arr_size. + Lemma get_sub_get ws lena len (t:WArray.array lena) i st: + WArray.get_sub AAscale ws len t i = ok st -> + forall j, (0 <= j < len)%Z -> + WArray.get AAscale ws st j = WArray.get AAscale ws t (i + j)%Z. + Proof. + move=> /WArray.get_sub_get8 => hr j hj. + rewrite /WArray.get !readE !WArray.is_align_scale. + have -> // : + mapM (λ k : Z, read st (add (j * mk_scale AAscale ws)%Z k) U8) (ziota 0 (wsize_size ws)) = + mapM (λ k : Z, read t (add ((i + j) * mk_scale AAscale ws)%Z k) U8) (ziota 0 (wsize_size ws)). + apply eq_mapM => k; rewrite in_ziota => /andP []/ZleP ? /ZltP ?. + rewrite hr /= !WArray.addE. + have ? := wsize_size_pos ws. + have -> /= : (0 <=? j * wsize_size ws + k)%Z. + + by apply/ZleP; Psatz.lia. + have -> /= : (j * wsize_size ws + k