diff --git a/Makefile b/Makefile index 7cae286509..c8eed8978b 100644 --- a/Makefile +++ b/Makefile @@ -140,7 +140,7 @@ CFRONTEND=Ctypes.v Cop.v Csyntax.v Csem.v Ctyping.v Cstrategy.v Cexec.v \ # Security proof (in security/) -SECURITY=RSC.v Split.v Blame.v Recomposition.v +SECURITY=RSC.v Split.v Blame.v Recomposition.v Tactics.v MemoryWeak.v MemoryDelta.v BtBasics.v BtInfoAsm.v BtInfoAsmBound.v Backtranslation.v BacktranslationAux.v BacktranslationProof.v # Parser diff --git a/backend/Allocproof.v b/backend/Allocproof.v index 0f09ddbf39..d43c1cab8a 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -52,6 +52,21 @@ Proof. - now inv H. Qed. +Instance external_transf_fundef: is_external_transl_partial transf_fundef. +Proof. + unfold transf_fundef, transf_partial_fundef, transf_function, check_function. + intros f ? ? H. + destruct f. + - destruct type_function; try easy. + destruct regalloc; try easy. + destruct analyze; try easy. + destruct eq_compartment as [e|?]; try easy. + monadInv H. monadInv EQ. + monadInv EQ0. + destruct check_entrypoints_aux; try easy. + - now inv H. +Qed. + Lemma transf_program_match: forall p tp, transf_program p = OK tp -> match_prog p tp. Proof. diff --git a/backend/CSEproof.v b/backend/CSEproof.v index dcd02836ce..80cf50c98d 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -31,6 +31,16 @@ Proof. now inv H. Qed. +Instance external_transf_function rm: + is_external_transl_partial (transf_fundef rm). +Proof. + unfold transf_fundef, transf_function. + intros [f | ef] ? ? H; try now inv H. + simpl in *. + destruct analyze; try easy. + now inv H. +Qed. + Lemma transf_program_match: forall prog tprog, transf_program prog = OK tprog -> match_prog prog tprog. Proof. diff --git a/backend/CleanupLabelsproof.v b/backend/CleanupLabelsproof.v index 11eea6f0be..04d1cea92a 100644 --- a/backend/CleanupLabelsproof.v +++ b/backend/CleanupLabelsproof.v @@ -27,6 +27,9 @@ Definition match_prog (p tp: Linear.program) := Instance comp_match_prog: has_comp_transl transf_function. Proof. now intros f. Qed. +Instance external_transf_fundef: is_external_transl transf_fundef. +Proof. now intros ? [f | ef]. Qed. + Lemma transf_program_match: forall p, match_prog p (transf_program p). Proof. diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index 00010d8124..70e07bbdcb 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -25,6 +25,9 @@ Definition match_prog (prog tprog: program) := Instance comp_transf_function rm: has_comp_transl (transf_function rm). Proof. now intro. Qed. +Instance external_transf_function rm: is_external_transl (transf_fundef rm). +Proof. now intros ? []. Qed. + Lemma transf_program_match: forall prog, match_prog prog (transf_program prog). Proof. diff --git a/backend/Deadcodeproof.v b/backend/Deadcodeproof.v index 8cbbd997cd..d6e9d42e16 100644 --- a/backend/Deadcodeproof.v +++ b/backend/Deadcodeproof.v @@ -30,6 +30,15 @@ Proof. now inv H. Qed. +Instance external_transf_function rm: is_external_transl_partial (transf_fundef rm). +Proof. + unfold transf_fundef, transf_function. + intros [f | ef] ? ? H; try now inv H. + simpl in *. + destruct analyze; try easy. + now inv H. +Qed. + Lemma transf_program_match: forall prog tprog, transf_program prog = OK tprog -> match_prog prog tprog. Proof. diff --git a/backend/Debugvarproof.v b/backend/Debugvarproof.v index 5b16beb1a0..1d309daea1 100644 --- a/backend/Debugvarproof.v +++ b/backend/Debugvarproof.v @@ -30,6 +30,14 @@ Proof. now destruct ana_function; inv H. Qed. +Instance external_transf_function: is_external_transl_partial transf_fundef. +Proof. + unfold transf_fundef, transf_function. + intros [f | ef] ? ? H; simpl in *. + now destruct ana_function; inv H. + now inv H. +Qed. + Lemma transf_program_match: forall p tp, transf_program p = OK tp -> match_prog p tp. Proof. diff --git a/backend/Inliningproof.v b/backend/Inliningproof.v index 0710a51708..20f7f9d2ec 100644 --- a/backend/Inliningproof.v +++ b/backend/Inliningproof.v @@ -31,6 +31,17 @@ Proof. now inv H. Qed. +Instance external_transl_fundef fenv: is_external_transl_partial (transf_fundef fenv). +Proof. + unfold transf_fundef, transf_function. + intros [f | ef] tf ? H; try now inv H. + unfold transf_partial_fundef in H. + destruct (expand_function _ _ _). + destruct (zlt _ _); try easy. + simpl in *. + now inv H. +Qed. + Lemma transf_program_match: forall prog tprog, transf_program prog = OK tprog -> match_prog prog tprog. Proof. diff --git a/backend/Linearizeproof.v b/backend/Linearizeproof.v index bcb67e28d1..156a5bca41 100644 --- a/backend/Linearizeproof.v +++ b/backend/Linearizeproof.v @@ -30,6 +30,12 @@ Proof. intros f ? H; now monadInv H. Qed. +Instance external_transf_fundef: is_external_transl_partial transf_fundef. +Proof. + unfold transf_fundef, transf_function. + intros [f | ef] ? ? H; now monadInv H. +Qed. + Lemma transf_program_match: forall p tp, transf_program p = OK tp -> match_prog p tp. Proof. diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v index 8f5117228f..f01fd61722 100644 --- a/backend/RTLgenproof.v +++ b/backend/RTLgenproof.v @@ -358,6 +358,15 @@ Proof. now inv H. Qed. +Instance external_transl_fundef: is_external_transl_partial transl_fundef. +Proof. + unfold transl_fundef, transl_function. + intros [f | ef] tf ? H; simpl in *. + - destruct (transl_fun _ _) as [|[??] ? ?]; try discriminate. + now inv H. + - now inv H. +Qed. + Lemma transf_program_match: forall p tp, transl_program p = OK tp -> match_prog p tp. Proof. diff --git a/backend/Renumberproof.v b/backend/Renumberproof.v index 548b9bb768..49e5bb5bd5 100644 --- a/backend/Renumberproof.v +++ b/backend/Renumberproof.v @@ -23,6 +23,9 @@ Definition match_prog (p tp: RTL.program) := Instance comp_transf_function: has_comp_transl transf_function. Proof. now intros. Qed. +Instance is_external_transf_function: is_external_transl transf_fundef. +Proof. unfold transf_fundef. intros ? [f | ef]; reflexivity. Qed. + Lemma transf_program_match: forall p, match_prog p (transf_program p). Proof. diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index 278f6e9f2d..3bf98428cd 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -46,6 +46,11 @@ Proof. exact (comp_transl_partial _ EQ). Qed. +Instance is_external_match_fundef: is_external_match match_fundef. +Proof. + intros cunit f tf cp (hf & hf_c & G & _ & H). + destruct f as [f|ef]; monadInv H; simpl; reflexivity. +Qed. (** Processing of helper functions *) Lemma record_globdefs_sound: diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index 0b10c30a2d..b5a40269c4 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -35,6 +35,12 @@ Proof. now monadInv H. Qed. +Instance external_transf_fundef: is_external_transl_partial transf_fundef. +Proof. + unfold transf_fundef. + intros [f | ef] tf ? H; try now monadInv H. +Qed. + Lemma transf_program_match: forall p tp, transf_program p = OK tp -> match_prog p tp. Proof. diff --git a/backend/Tailcallproof.v b/backend/Tailcallproof.v index e9b40ee675..a34de3790e 100644 --- a/backend/Tailcallproof.v +++ b/backend/Tailcallproof.v @@ -215,6 +215,12 @@ Proof. now destruct zeq. Qed. +Instance external_transf_fundef cenv: is_external_transl (transf_fundef cenv). +Proof. + unfold transf_fundef, transf_function, RTL.transf_function. + intros ? [f | ef]; simpl; reflexivity. +Qed. + Lemma transf_program_match: forall p, match_prog p (transf_program p). Proof. diff --git a/backend/Tunnelingproof.v b/backend/Tunnelingproof.v index c90eebceca..d775f6344c 100644 --- a/backend/Tunnelingproof.v +++ b/backend/Tunnelingproof.v @@ -25,6 +25,9 @@ Definition match_prog (p tp: program) := Instance comp_tunnel_fundef: has_comp_transl tunnel_function. Proof. now intro. Qed. +Instance external_tunnel_fundef: is_external_transl tunnel_fundef. +Proof. now intros ? []. Qed. + Lemma transf_program_match: forall p, match_prog p (tunnel_program p). Proof. diff --git a/backend/Unusedglobproof.v b/backend/Unusedglobproof.v index d3d9baf7a6..54e33dfc43 100644 --- a/backend/Unusedglobproof.v +++ b/backend/Unusedglobproof.v @@ -866,7 +866,7 @@ Proof. simpl. rewrite A. rewrite H0. subst; now destruct Ptrofs.eq_dec. + right. unfold Genv.allowed_cross_call in *. - destruct H2 as [i [cp' [H21 [H22 [H23 H24]]]]]. + destruct H2 as [i [cp' [H21 [H22 [H23 [H24 H25]]]]]]. exists i. exists cp'. repeat split. * apply Genv.find_invert_symbol. @@ -875,16 +875,20 @@ Proof. specialize (E j H). unfold symbols_inject in E. destruct E as [E1 [E2 [E3 E4]]]. specialize (E2 i _ _ _ H6). simpl in E2. specialize (E2 H21). destruct E2. auto. - * rewrite <- H22. unfold Genv.find_comp. + * intros. unfold Genv.find_funct in *. + destruct (Ptrofs.eq_dec (Ptrofs.add Ptrofs.zero (Ptrofs.repr delta)) Ptrofs.zero); try congruence. + assert (fd0 = fd) by congruence; subst fd0. + apply H22. eauto. + * rewrite <- H23. unfold Genv.find_comp. simpl. rewrite A. rewrite H0. subst; now destruct Ptrofs.eq_dec. * apply match_prog_pol in TRANSF. unfold tge, Genv.globalenv. rewrite TRANSF. rewrite Genv.genv_pol_add_globals. simpl. - unfold ge, Genv.globalenv in H23. now rewrite Genv.genv_pol_add_globals in H23. + unfold ge, Genv.globalenv in H24. now rewrite Genv.genv_pol_add_globals in H24. * apply match_prog_pol in TRANSF. unfold tge, Genv.globalenv. rewrite TRANSF. rewrite Genv.genv_pol_add_globals. simpl. - unfold ge, Genv.globalenv in H24. now rewrite Genv.genv_pol_add_globals in H24. } + unfold ge, Genv.globalenv in H25. now rewrite Genv.genv_pol_add_globals in H25. } { unfold Genv.type_of_call. unfold Genv.find_comp, Genv.find_funct. rewrite R, H0, A, B. now destruct Ptrofs.eq_dec. } { unfold Genv.find_comp, Genv.find_funct. rewrite R, H0, A, B. reflexivity. } @@ -913,12 +917,16 @@ Proof. specialize (E j H). unfold symbols_inject in E. destruct E as [E1 [E2 [E3 E4]]]. specialize (E2 i _ _ _ Q). simpl in E2. specialize (E2 H21). destruct E2. auto. - * rewrite <- H22. unfold Genv.find_comp. + * intros. unfold Genv.find_funct in *. + destruct Ptrofs.eq_dec; try congruence. + assert (fd0 = fd) by congruence; subst fd0. + apply H22. eauto. + * rewrite <- H23. unfold Genv.find_comp. simpl. rewrite A. rewrite H0. reflexivity. * apply match_prog_pol in TRANSF. unfold tge, Genv.globalenv. rewrite TRANSF. rewrite Genv.genv_pol_add_globals. simpl. - unfold ge, Genv.globalenv in H23. now rewrite Genv.genv_pol_add_globals in H23. + unfold ge, Genv.globalenv in H24. now rewrite Genv.genv_pol_add_globals in H24. * apply match_prog_pol in TRANSF. unfold tge, Genv.globalenv. rewrite TRANSF. rewrite Genv.genv_pol_add_globals. simpl. diff --git a/cfrontend/Cminorgenproof.v b/cfrontend/Cminorgenproof.v index 3d7e16c6eb..e748a7b68b 100644 --- a/cfrontend/Cminorgenproof.v +++ b/cfrontend/Cminorgenproof.v @@ -42,6 +42,16 @@ Proof. now monadInv H. Qed. +Instance external_transl_fundef: is_external_transl_partial transl_fundef. +Proof. + unfold transl_fundef, transl_function, transl_funbody. + intros [f | ef] tf ? H; simpl in H. + destruct build_compilenv. + destruct zle; try easy. + now monadInv H. + now monadInv H. +Qed. + Lemma transf_program_match: forall p tp, transl_program p = OK tp -> match_prog p tp. Proof. diff --git a/cfrontend/Csem.v b/cfrontend/Csem.v index 9e12ed4353..2daaf81c9b 100644 --- a/cfrontend/Csem.v +++ b/cfrontend/Csem.v @@ -884,3 +884,4 @@ Proof. inv H; simpl; try lia. eapply external_call_trace_length; eauto. inv EV; simpl; try lia. Qed. + diff --git a/cfrontend/Cshmgenproof.v b/cfrontend/Cshmgenproof.v index c7df0ff74a..46faa44bdd 100644 --- a/cfrontend/Cshmgenproof.v +++ b/cfrontend/Cshmgenproof.v @@ -44,6 +44,11 @@ Proof. exact (comp_transl_partial _ H). Qed. +Instance external_match_fundef: is_external_match match_fundef. +Proof. + intros cu ? ? ? [f tf H|]; reflexivity. +Qed. + Lemma transf_program_match: forall p tp, transl_program p = OK tp -> match_prog p tp. Proof. diff --git a/cfrontend/Csyntax.v b/cfrontend/Csyntax.v index 7b20544234..74fe3d2f31 100644 --- a/cfrontend/Csyntax.v +++ b/cfrontend/Csyntax.v @@ -17,7 +17,7 @@ (** Abstract syntax for the Compcert C language *) Require Import Coqlib Maps Integers Floats Errors. -Require Import AST Linking Values. +Require Import AST Linking Values Builtins. Require Import Ctypes Cop. (** ** Expressions *) @@ -227,3 +227,4 @@ Definition type_of_fundef (f: fundef) : type := - a proof that this environment is consistent with the definitions. *) Definition program := Ctypes.program function. + diff --git a/cfrontend/Ctypes.v b/cfrontend/Ctypes.v index 1593ce0fc7..492f530827 100644 --- a/cfrontend/Ctypes.v +++ b/cfrontend/Ctypes.v @@ -17,7 +17,7 @@ (** Type expressions for the Compcert C and Clight languages *) Require Import Axioms Coqlib Maps Errors. -Require Import AST Linking. +Require Import AST Linking Builtins. Require Archi. Set Asymmetric Patterns. @@ -2021,3 +2021,60 @@ Qed. End LINK_MATCH_PROGRAM. + +Global Program Instance is_external_fundef_ctypes f : is_external (fundef f) := + { is_ok := + fun cp' fd => + match fd with + | Internal _ => True + | External ef _ _ _ => + match ef with + | EF_external cp name sg => True + | EF_builtin cp name sg + | EF_runtime cp name sg => + match Builtins.lookup_builtin_function name sg with + | None => True + | _ => cp = cp' + end + | EF_vload cp chunk => cp = cp' + | EF_vstore cp chunk => cp = cp' + | EF_malloc cp => cp = cp' + | EF_free cp => cp = cp' + | EF_memcpy cp sz al => cp = cp' + | EF_annot cp kind txt targs => True + | EF_annot_val cp kind txt targ => True + | EF_inline_asm cp txt sg clb => True + | EF_debug cp kind txt targs => cp = cp' + end + end; + is_ok_b := + fun cp' fd => + match fd with + | Internal _ => true + | External ef _ _ _ => + match ef with + | EF_external cp name sg => true + | EF_builtin cp name sg + | EF_runtime cp name sg => + match lookup_builtin_function name sg with + | None => true + | _ => Pos.eqb cp cp' + end + | EF_vload cp chunk => Pos.eqb cp cp' + | EF_vstore cp chunk => Pos.eqb cp cp' + | EF_malloc cp => Pos.eqb cp cp' + | EF_free cp => Pos.eqb cp cp' + | EF_memcpy cp sz al => Pos.eqb cp cp' + | EF_annot cp kind txt targs => true + | EF_annot_val cp kind txt targ => true + | EF_inline_asm cp txt sg clb => true + | EF_debug cp kind txt targs => Pos.eqb cp cp' + end + end; + is_ok_reflect := _; + }. +Next Obligation. + destruct fd as [| []]; simpl; try now (symmetry; eauto using Pos.eqb_eq). + destruct (lookup_builtin_function name sg); try now (symmetry; eauto using Pos.eqb_eq). + destruct (lookup_builtin_function name sg); try now (symmetry; eauto using Pos.eqb_eq). +Defined. diff --git a/cfrontend/SimplExprproof.v b/cfrontend/SimplExprproof.v index dcecb89c16..50a8ffa871 100644 --- a/cfrontend/SimplExprproof.v +++ b/cfrontend/SimplExprproof.v @@ -39,6 +39,13 @@ Proof. symmetry; eauto. Qed. +Instance external_tr_fundef: + is_external_match (fun cu f tf => tr_fundef cu f tf). +Proof. + intros ctx f tf ? [? ? []|]; reflexivity. +Qed. + + Lemma transf_program_match: forall p tp, transl_program p = OK tp -> match_prog p tp. Proof. diff --git a/cfrontend/SimplLocalsproof.v b/cfrontend/SimplLocalsproof.v index 9ca8b20d9a..2b945221d8 100644 --- a/cfrontend/SimplLocalsproof.v +++ b/cfrontend/SimplLocalsproof.v @@ -38,6 +38,11 @@ Proof. now monadInv EQ. Qed. +Instance external_transf_fundef: is_external_transl_partial transf_fundef. +Proof. + intros [f | ef] ? ? H; monadInv H; reflexivity. +Qed. + Lemma match_transf_program: forall p tp, transf_program p = OK tp -> match_prog p tp. Proof. diff --git a/common/AST.v b/common/AST.v index d821e560be..bd0cf57b83 100644 --- a/common/AST.v +++ b/common/AST.v @@ -792,6 +792,66 @@ Proof. Defined. Global Opaque external_function_eq. +Class is_external (F: Type) := { + is_ok: compartment -> F -> Prop; + is_ok_b: compartment -> F -> bool; + is_ok_reflect: forall cp fd, is_ok cp fd <-> is_ok_b cp fd = true + }. + +Class is_external_match {C T S: Type} {ET: is_external T} {ES: is_external S} + (R : C -> T -> S -> Prop) := + ok_match: + forall c x y cp, R c x y -> is_ok cp x <-> is_ok cp y. + +Class is_external_transl {T S: Type} + {CT: is_external T} {CS: is_external S} + (f : T -> S) := + ok_transl: + forall cp x, is_ok cp (f x) <-> is_ok cp x. + +Instance is_external_transl_match: + forall {C T S: Type} + {CT: is_external T} {CS: is_external S} + (f: T -> S) {Cf: is_external_transl f}, + is_external_match (fun (c : C) x y => y = f x). +Proof. now intros C T S ???? c x y cp ->; rewrite ok_transl. Qed. + +Class is_external_transl_partial {T S: Type} + {ET: is_external T} {ES: is_external S} + (f : T -> res S) := + ok_transl_partial: + forall x y cp, f x = OK y -> is_ok cp x <-> is_ok cp y. + +Instance is_external_transl_partial_match: + forall {C T S: Type} + {ET: is_external T} {ES: is_external S} + (f : T -> res S) + {Cf: is_external_transl_partial f}, + is_external_match (fun (c : C) x y => f x = OK y). +Proof. + intros C T S ???? c. exact ok_transl_partial. +Qed. + +Instance is_external_transl_match_contextual: + forall {C D T S: Type} + {CT: is_external T} {CS: is_external S} + (f: D -> T -> S) {Cf: forall d, is_external_transl (f d)} + (g: C -> D), + is_external_match (fun (c : C) x y => y = f (g c) x). +Proof. +now intros C D T S CT CS f Cf g ???? ->; rewrite ok_transl. +Qed. + +Instance is_external_transl_partial_match_contextual: + forall {C D T S: Type} + {CT: is_external T} {CS: is_external S} + (f: D -> T -> res S) {Cf: forall d, is_external_transl_partial (f d)} + (g: C -> D), + is_external_match (fun (c : C) x y => f (g c) x = OK y). +Proof. +intros C D T S CT CS f Cf g c. exact ok_transl_partial. +Qed. + (** Function definitions are the union of internal and external functions. *) Inductive fundef (F: Type): Type := diff --git a/common/Events.v b/common/Events.v index 6b991d74cf..8f680b7a19 100644 --- a/common/Events.v +++ b/common/Events.v @@ -700,6 +700,16 @@ Record extcall_properties (sem: extcall_sem) (sg: signature) : Prop := sem ge vargs m1 t vres m2 -> Mem.valid_block m1 b -> Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p; +(* New property *) +(** External calls cannot free public blocks without the Max Freeable permission *) + ec_public_not_freeable: + forall ge vargs m1 t vres m2 b ofs id, + sem ge vargs m1 t vres m2 -> + Mem.valid_block m1 b -> + Senv.invert_symbol ge b = Some id -> Senv.public_symbol ge id = true -> + Mem.perm m1 b ofs Max Nonempty -> (~ Mem.perm m1 b ofs Max Freeable) -> + Mem.perm m2 b ofs Max Nonempty; + (** External call cannot modify memory unless they have [Max, Writable] permissions. *) ec_readonly: @@ -854,6 +864,8 @@ Proof. - inv H; auto. (* max perms *) - inv H; auto. +(* not freeable *) +- inv H; auto. (* readonly *) - inv H; auto. (* mem extends *) @@ -1025,6 +1037,8 @@ Proof. - inv H. inv H1. auto. eapply Mem.store_can_access_block_inj in H2. eapply H2. eauto. (* perms *) - inv H. inv H2. auto. eauto with mem. +(* not freeable *) +- inv H. inv H5; auto. eauto with mem. (* readonly *) - inv H. eapply unchanged_on_readonly; eauto. eapply volatile_store_readonly; eauto. (* mem extends*) @@ -1092,6 +1106,8 @@ Proof. - inv H. exploit Mem.perm_alloc_inv. eauto. eapply Mem.perm_store_2; eauto. rewrite dec_eq_false. auto. apply Mem.valid_not_valid_diff with m1; eauto with mem. +(* not freeable *) +- inv H. eapply Mem.perm_store_1; eauto. eapply Mem.perm_alloc_1; eauto. (* readonly *) - inv H. eapply unchanged_on_readonly; eauto. (* mem extends *) @@ -1171,6 +1187,10 @@ Proof. - inv H; eauto. eapply Mem.free_can_access_block_inj_1; eauto. (* perms *) - inv H; eauto using Mem.perm_free_3. +(* not freeable *) +- inv H; auto. eapply Mem.perm_free_1; eauto. eapply Mem.free_range_perm in H7. unfold Mem.range_perm in H7. specialize (H7 ofs). + destruct (Z.le_gt_cases (Ptrofs.unsigned lo - size_chunk Mptr) ofs); destruct (Z.lt_ge_cases ofs (Ptrofs.unsigned lo + Ptrofs.unsigned sz)); try lia. + left. intros EQ. subst b0. apply H4. eapply Mem.perm_max. eapply H7. lia. (* readonly *) - eapply unchanged_on_readonly; eauto. inv H. + eapply Mem.free_unchanged_on; eauto. @@ -1286,6 +1306,8 @@ Proof. intros. inv H. eapply Mem.storebytes_can_access_block_inj_1; eauto. - (* perms *) intros. inv H. eapply Mem.perm_storebytes_2; eauto. +- (* not freeable *) + intros. inv H. eapply Mem.perm_storebytes_1; eauto. - (* readonly *) intros. inv H. eapply unchanged_on_readonly; eauto. eapply Mem.storebytes_unchanged_on; eauto. @@ -1411,6 +1433,8 @@ Proof. - inv H; auto. (* perms *) - inv H; auto. +(* not freeable *) +- inv H; auto. (* readonly *) - inv H; auto. (* mem extends *) @@ -1458,6 +1482,8 @@ Proof. - inv H; auto. (* perms *) - inv H; auto. +(* not freeable *) +- inv H; auto. (* readonly *) - inv H; auto. (* mem extends *) @@ -1503,6 +1529,8 @@ Proof. - inv H; auto. (* perms *) - inv H; auto. +(* not freeable *) +- inv H; auto. (* readonly *) - inv H; auto. (* mem extends *) @@ -1556,6 +1584,8 @@ Proof. - inv H; auto. (* perms *) - inv H; auto. +(* not freeable *) +- inv H; auto. (* readonly *) - inv H; auto. (* mem extends *) @@ -1666,7 +1696,7 @@ Definition external_call (ef: external_function): extcall_sem := | EF_annot cp kind txt targs => extcall_annot_sem cp txt targs | EF_annot_val cp kind txt targ => extcall_annot_val_sem cp txt targ | EF_inline_asm cp txt sg clb => inline_assembly_sem cp txt sg - | EF_debug kind cp txt targs => extcall_debug_sem cp + | EF_debug cp kind txt targs => extcall_debug_sem cp end. Ltac external_call_caller_independent := @@ -1741,6 +1771,7 @@ Definition external_call_symbols_preserved ef := ec_symbols_preserved (external_ Definition external_call_valid_block ef := ec_valid_block (external_call_spec ef). Definition external_call_can_access_block ef := ec_can_access_block (external_call_spec ef). Definition external_call_max_perm ef := ec_max_perm (external_call_spec ef). +Definition external_call_public_not_freeable ef := ec_public_not_freeable (external_call_spec ef). Definition external_call_readonly ef := ec_readonly (external_call_spec ef). Definition external_call_mem_extends ef := ec_mem_extends (external_call_spec ef). Definition external_call_mem_inject_gen ef := ec_mem_inject (external_call_spec ef). @@ -2120,3 +2151,184 @@ Section INFORM_TRACES_PRESERVED. Qed. End INFORM_TRACES_PRESERVED. + + +Section VISIBLE. + + (* Memory location has only sequence of bytes *) + Definition loc_first_order (m: mem) (b: block) (ofs: Z) : Prop := + match (ZMap.get ofs (Mem.mem_contents m) !! b) with + | Byte _ => True + | _ => False + end. + + (* Public symbols are visible outside the compilation unit, + so when interacting via external calls, limit them to first-order (if Readable). *) + Definition public_first_order (ge: Senv.t) (m: mem) := + forall id b ofs + (PUBLIC: Senv.public_symbol ge id = true) + (FIND: Senv.find_symbol ge id = Some b) + (READABLE: Mem.perm m b ofs Cur Readable), + loc_first_order m b ofs. + + Definition block_public (ge: Senv.t) (b: block): Prop := + exists id, Senv.invert_symbol ge b = Some id /\ Senv.public_symbol ge id = true. + + Variant val_public (ge: Senv.t) : typ -> val -> Prop := + | val_public_int: forall i, val_public ge Tint (Vint i) + | val_public_long: forall i, val_public ge Tlong (Vlong i) + | val_public_float: forall f, val_public ge Tfloat (Vfloat f) + | val_public_single: forall f, val_public ge Tsingle (Vsingle f) + | val_public_ptr: forall b ofs, block_public ge b -> val_public ge Tptr (Vptr b ofs). + + Definition vals_public (ge: Senv.t) (ts: list typ) (vs: list val): Prop := + Forall2 (val_public ge) ts vs. + + Definition visible_fo (ge: Senv.t) (m: mem) (tys: list typ) (args: list val): Prop := + public_first_order ge m /\ vals_public ge tys args. + + Definition EF_memcpy_dest_not_pub (ge: Senv.t) (args: list val) := + match args with + | (Vptr bdst _) :: tl => ~ (block_public ge bdst) + | _ => True + end. + + Definition load_whole_chunk (ch: memory_chunk) (v: val) := Val.load_result ch v = v. + + Definition EF_vstore_load_whole_chunk (ch: memory_chunk) (args: list val) := + match args with + | _ :: v :: nil => load_whole_chunk ch v + | _ => True + end. + + Definition external_call_conds + (ef: external_function) (ge: Senv.t) (m: mem) (args: list val) : Prop := + match ef with + | EF_external cp name sg => visible_fo ge m (sig_args sg) args + | EF_builtin cp name sg | EF_runtime cp name sg => + match lookup_builtin_function name sg with + | None => visible_fo ge m (sig_args sg) args + | _ => True + end + | EF_inline_asm cp txt sg clb => visible_fo ge m (sig_args sg) args + | EF_memcpy cp sz al => EF_memcpy_dest_not_pub ge args + | EF_vstore cp ch => EF_vstore_load_whole_chunk ch args + | _ => True + end. + + Definition external_call_unknowns + (ef: external_function) (ge: Senv.t) (m: mem) (args: list val) : Prop := + match ef with + | EF_external cp name sg => visible_fo ge m (sig_args sg) args + | EF_builtin cp name sg | EF_runtime cp name sg => + match lookup_builtin_function name sg with + | None => visible_fo ge m (sig_args sg) args + | _ => False + end + | EF_inline_asm cp txt sg clb => visible_fo ge m (sig_args sg) args + | _ => False + end. + + Definition external_call_known_observables + (ef: external_function) (ge: Senv.t) (m: mem) (args: list val) tr rv m' : Prop := + match ef with + | EF_external cp name sg => False + | EF_builtin cp name sg | EF_runtime cp name sg => False + | EF_inline_asm cp txt sg clb => False + | EF_vstore cp ch => + (external_call ef ge args m tr rv m') /\ (tr <> E0) /\ (EF_vstore_load_whole_chunk ch args) + | _ => (external_call ef ge args m tr rv m') /\ (tr <> E0) + end. + + Definition external_call_known_silents + (ef: external_function) (ge: Senv.t) (m: mem) (args: list val) tr rv m': Prop := + match ef with + | EF_external cp name sg => False + | EF_builtin cp name sg | EF_runtime cp name sg => + match lookup_builtin_function name sg with + | None => False + | _ => True + end + | EF_inline_asm cp txt sg clb => False + | EF_memcpy cp sz al => + (external_call ef ge args m E0 rv m') /\ (tr = E0) /\ (EF_memcpy_dest_not_pub ge args) + | _ => (external_call ef ge args m E0 rv m') /\ (tr = E0) + end. + + + (* Remove? *) + (* (* Should be ensured by the user *) *) + (* Definition unknown_returns_fo_pub *) + (* (ef: external_function) (ge: Senv.t) (m: mem) (args: list val) : Prop := *) + (* match ef with *) + (* | EF_external cp name sg => *) + (* forall ge args m0 tr rv m1, (external_functions_sem name sg ge args m0 tr rv m1) -> public_first_order ge m1 *) + (* | EF_builtin cp name sg *) + (* | EF_runtime cp name sg => *) + (* match lookup_builtin_function name sg with *) + (* | None => forall ge args m0 tr rv m1, (external_functions_sem name sg ge args m0 tr rv m1) -> public_first_order ge m1 *) + (* | _ => True *) + (* end *) + (* | EF_inline_asm cp txt sg clb => *) + (* forall ge args m0 tr rv m1, (inline_assembly_sem cp txt sg ge args m0 tr rv m1) -> public_first_order ge m1 *) + (* | _ => True *) + (* end. *) + +End VISIBLE. + +Global Program Instance is_external_fundef (F: Type) : is_external (fundef F) := + { is_ok := + fun cp' fd => + match fd with + | Internal _ => True + | External ef => + match ef with + | EF_external cp name sg => True + | EF_builtin cp name sg + | EF_runtime cp name sg => + match lookup_builtin_function name sg with + | None => True + | _ => cp = cp' + end + | EF_vload cp chunk => cp = cp' + | EF_vstore cp chunk => cp = cp' + | EF_malloc cp => cp = cp' + | EF_free cp => cp = cp' + | EF_memcpy cp sz al => cp = cp' + | EF_annot cp kind txt targs => True + | EF_annot_val cp kind txt targ => True + | EF_inline_asm cp txt sg clb => True + | EF_debug cp kind txt targs => cp = cp' + end + end; + is_ok_b := + fun cp' fd => + match fd with + | Internal _ => true + | External ef => + match ef with + | EF_external cp name sg => true + | EF_builtin cp name sg + | EF_runtime cp name sg => + match lookup_builtin_function name sg with + | None => true + | _ => Pos.eqb cp cp' + end + | EF_vload cp chunk => Pos.eqb cp cp' + | EF_vstore cp chunk => Pos.eqb cp cp' + | EF_malloc cp => Pos.eqb cp cp' + | EF_free cp => Pos.eqb cp cp' + | EF_memcpy cp sz al => Pos.eqb cp cp' + | EF_annot cp kind txt targs => true + | EF_annot_val cp kind txt targ => true + | EF_inline_asm cp txt sg clb => true + | EF_debug cp kind txt targs => Pos.eqb cp cp' + end + end; + is_ok_reflect := _; + }. +Next Obligation. + destruct fd as [| []]; simpl; try now (symmetry; eauto using Pos.eqb_eq). + destruct (lookup_builtin_function name sg); try now (symmetry; eauto using Pos.eqb_eq). + destruct (lookup_builtin_function name sg); try now (symmetry; eauto using Pos.eqb_eq). +Defined. diff --git a/common/Globalenvs.v b/common/Globalenvs.v index 122808db81..6e754bf0a1 100644 --- a/common/Globalenvs.v +++ b/common/Globalenvs.v @@ -143,6 +143,7 @@ Section GENV. Variable F: Type. (**r The type of function descriptions *) Variable V: Type. (**r The type of information attached to variables *) +Context {EF: is_external F}. Context {CF: has_comp F}. (** The type of global environments. *) @@ -1884,17 +1885,18 @@ Qed. Definition allowed_cross_call (ge: t) (cp: compartment) (vf: val) := match vf with | Vptr b _ => - exists i cp', - invert_symbol ge b = Some i /\ - find_comp ge vf = cp' /\ - match (Policy.policy_import ge.(genv_policy)) ! cp with - | Some l => In (cp', i) l - | None => False - end /\ - match (Policy.policy_export ge.(genv_policy)) ! cp' with - | Some l => In i l - | None => False - end + exists i cp', + invert_symbol ge b = Some i /\ + (forall fd, find_funct ge vf = Some fd -> is_ok cp fd) /\ + find_comp ge vf = cp' /\ + match (Policy.policy_import ge.(genv_policy)) ! cp with + | Some l => In (cp', i) l + | None => False + end /\ + match (Policy.policy_export ge.(genv_policy)) ! cp' with + | Some l => In i l + | None => False + end | _ => False end. @@ -1945,23 +1947,30 @@ Qed. Definition allowed_call_b (ge: t) (cp: compartment) (vf: val): bool := match find_comp ge vf with | c => Pos.eqb c cp - || match vf with - | Vptr b _ => match invert_symbol ge b with - | Some i => - match (Policy.policy_import ge.(genv_policy)) ! cp with - | Some imps => - match (Policy.policy_export ge.(genv_policy)) ! c with - | Some exps => - in_dec comp_ident_eq_dec (c, i) imps && - in_dec Pos.eq_dec i exps + || ((match vf with + | Vptr b _ => match invert_symbol ge b with + | Some i => + match (Policy.policy_import ge.(genv_policy)) ! cp with + | Some imps => + match (Policy.policy_export ge.(genv_policy)) ! c with + | Some exps => + in_dec comp_ident_eq_dec (c, i) imps && + in_dec Pos.eq_dec i exps + | None => false + end | None => false end | None => false end - | None => false - end - | _ => false - end + | _ => false + end) + && + (match find_funct ge vf with + | Some fd => is_ok_b cp fd + | None => true + end + ) + ) end. Lemma allowed_call_reflect: forall ge cp vf, @@ -1972,23 +1981,30 @@ Proof. destruct (Pos.eqb_spec (find_comp ge vf) cp); subst; firstorder. - destruct vf eqn:VF; try (firstorder; discriminate). subst. - destruct H as (i' & cp' & A & B & C & D). + destruct H as (i' & cp' & A & B & C & D & E). rewrite A. destruct ((Policy.policy_import (genv_policy ge)) ! cp) as [imps |]; auto. - rewrite B. + rewrite C. destruct ((Policy.policy_export (genv_policy ge)) ! cp') as [exps |]; auto. destruct (in_dec comp_ident_eq_dec (cp', i') imps); destruct (in_dec Pos.eq_dec i' exps); simpl; auto. + destruct (Ptrofs.eq_dec); auto. destruct (find_funct_ptr ge b) eqn:FD; auto. + apply is_ok_reflect. eapply B. unfold find_funct. rewrite e, FD. + now destruct Ptrofs.eq_dec. - destruct vf eqn:VF; try (firstorder; discriminate). subst. right. simpl in H. destruct (invert_symbol ge b) eqn:A; try discriminate. destruct ((Policy.policy_import (genv_policy ge)) ! cp) eqn:B; try discriminate. destruct ((Policy.policy_export (genv_policy ge)) ! (find_comp ge (Vptr b i))) eqn:C; try discriminate. apply andb_prop in H. destruct H as (D & E). - eexists; eexists; split; [reflexivity | split; [reflexivity |]]. + apply andb_prop in D. destruct D as (D0 & D1). + eexists; eexists; split; [reflexivity | split; [| split; [reflexivity | ]]]. + { intros. rewrite is_ok_reflect. unfold find_funct in H. destruct Ptrofs.eq_dec. + - now rewrite H in E. + - congruence. + } rewrite C. - apply proj_sumbool_true in D. - apply proj_sumbool_true in E. auto. + apply proj_sumbool_true in D0, D1. auto. Qed. Section SECURITY. @@ -2047,12 +2063,14 @@ End MATCH_GENVS. Section MATCH_PROGRAMS. Context {C F1 V1 F2 V2: Type} {LC: Linker C} {LF: Linker F1} {LV: Linker V1}. +Context {EF1: is_external F1} {EF2: is_external F2}. Context {CF1: has_comp F1} {CF2: has_comp F2}. Variable match_fundef: C -> F1 -> F2 -> Prop. Variable match_varinfo: V1 -> V2 -> Prop. Variable ctx: C. Variable p: program F1 V1. Variable tp: program F2 V2. +Context {match_fundef_external: is_external_match match_fundef}. Context {match_fundef_comp: has_comp_match match_fundef}. Hypothesis progmatch: match_program_gen match_fundef match_varinfo ctx p tp. @@ -2238,18 +2256,19 @@ Proof. unfold allowed_cross_call in *. rewrite match_genvs_find_comp in H1. destruct vf; auto. - destruct H1 as [i0 [cp' [? [? [? ?]]]]]. - exists i0; exists cp'; split; [| split; [| split]]. + destruct H1 as [i0 [cp' [? [? [? [? ?]]]]]]. + exists i0; exists cp'; split; [| split; [| split; [| split]]]. - apply find_invert_symbol. apply invert_find_symbol in H. rewrite find_symbol_match; eauto. + - intros. exploit find_funct_match_conv; eauto. intros (? & ? & ? & ? & ?). eapply match_fundef_external. eauto. eapply H0; eauto. - now auto. - destruct progmatch as [? [? [? EQPOL]]]. destruct p, tp; simpl in *; subst. - unfold globalenv. unfold globalenv in H1. + unfold globalenv. unfold globalenv in H2. simpl in *. - clear -H1 EQPOL. + clear -H2 EQPOL. rewrite genv_pol_add_globals. - rewrite genv_pol_add_globals in H1. + rewrite genv_pol_add_globals in H2. unfold Policy.eqb in EQPOL. apply andb_prop in EQPOL. destruct EQPOL as [EQPOL1 EQPOL2]. simpl in *. @@ -2258,12 +2277,12 @@ Proof. destruct ((Policy.policy_import prog_pol) ! cp); auto. destruct (Policy.list_cpt_id_eq l l0); subst; simpl in *; auto; try discriminate. contradiction. - destruct progmatch as [? [? [? EQPOL]]]. - rewrite <- match_genvs_find_comp in H0. + rewrite <- match_genvs_find_comp in H1. destruct p, tp; simpl in *; subst. - unfold globalenv. unfold globalenv in H2. - simpl in *. clear -H2 EQPOL CF2. + unfold globalenv. unfold globalenv in H3. + simpl in *. clear -H3 EQPOL CF2. rewrite genv_pol_add_globals. - rewrite genv_pol_add_globals in H2. + rewrite genv_pol_add_globals in H3. unfold Policy.eqb in EQPOL. apply andb_prop in EQPOL. destruct EQPOL as [EQPOL1 EQPOL2]. simpl in *. @@ -2346,8 +2365,10 @@ End MATCH_PROGRAMS. Section TRANSFORM_PARTIAL. Context {A B V: Type} {LA: Linker A} {LV: Linker V}. +Context {EA: is_external A} {EB: is_external B}. Context {CA: has_comp A} {CB: has_comp B}. Context {transf: A -> res B} {p: program A V} {tp: program B V}. +Context {EAB: is_external_transl_partial transf}. Context {CAB: has_comp_transl_partial transf}. Hypothesis progmatch: match_program (fun cu f tf => transf f = OK tf) eq p tp. @@ -2501,8 +2522,10 @@ Section TRANSFORM_TOTAL. Context {A B V: Type} {LA: Linker A} {LV: Linker V}. Context {CA: has_comp A} {CB: has_comp B}. +Context {EA: is_external A} {EB: is_external B}. Context {transf: A -> B} {p: program A V} {tp: program B V}. Context {CAB: has_comp_transl transf}. +Context {EAB: is_external_transl transf}. Hypothesis progmatch: match_program (fun cu f tf => tf = transf f) eq p tp. Theorem find_funct_ptr_transf: diff --git a/riscV/Asm.v b/riscV/Asm.v index 5693b0d620..7916ac11f3 100644 --- a/riscV/Asm.v +++ b/riscV/Asm.v @@ -1252,7 +1252,7 @@ Definition update_stack_return (s: stack) (cp: compartment) rs' := else (* Otherwise we just pop the top stackframe, if it exists *) match s with - | nil => Some nil + | nil => None | _ :: st' => Some st' end . @@ -1299,6 +1299,13 @@ Definition sig_of_call s := | _ => signature_main end. +Definition funsig (fd: fundef): signature := + match fd with + | Internal f => fn_sig f + | External ef => ef_sig ef + end. + +(* TODO: replace with step_fix *) Inductive step: state -> trace -> state -> Prop := | exec_step_internal: forall b ofs f i rs m rs' m' b' ofs' st cp, @@ -1392,6 +1399,118 @@ Inductive step: state -> trace -> state -> Prop := forall (REC_CURCOMP: Genv.find_comp_ignore_offset ge (rs PC) = callee_comp st), step (State st rs m) t (ReturnState st rs' m'). +(* 4 fixes: +check sig when call (CALLSIG), +public symbols and args are first-order when undefined external calls/builtins (ECC), +builtin result register is only from mreg (map_builtin_res preg_of res), +before cross-compartment call/return, check that public symbols are first-order (CHECKPUB) +*) +Inductive step_fix: state -> trace -> state -> Prop := +| exec_step_fix_internal: + forall b ofs f i rs m rs' m' b' ofs' st cp, + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_instr (Ptrofs.unsigned ofs) (fn_code f) = Some i -> + forall (COMP: comp_of f = cp), + exec_instr f i rs m cp = Next rs' m' -> + sig_call i = None -> + is_return i = false -> + forall (NEXTPC: rs' PC = Vptr b' ofs'), + forall (ALLOWED: cp = Genv.find_comp_ignore_offset ge (Vptr b' ofs')), + step_fix (State st rs m) E0 (State st rs' m') +| exec_step_fix_internal_call: + forall b ofs f i sig rs m rs' m' b' ofs' cp st st' args t, + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_instr (Ptrofs.unsigned ofs) (fn_code f) = Some i -> + exec_instr f i rs m cp = Next rs' m' -> + sig_call i = Some sig -> + forall (NEXTPC: rs' PC = Vptr b' ofs'), + forall (ALLOWED: Genv.allowed_call ge (comp_of f) (Vptr b' Ptrofs.zero)), + forall (CURCOMP: Genv.find_comp_ignore_offset ge (Vptr b Ptrofs.zero) = cp), + (* Is a call, we update the stack *) + forall (STUPD: update_stack_call st sig cp rs' = Some st'), + forall (ARGS: call_arguments rs' m' sig args), + (* Is a call, we check whether we are allowed to pass pointers *) + forall (NO_CROSS_PTR: + Genv.type_of_call ge (comp_of f) (Genv.find_comp_ignore_offset ge (Vptr b' ofs')) = Genv.CrossCompartmentCall -> + List.Forall not_ptr args), + forall (EV: call_trace ge (comp_of f) (Genv.find_comp_ignore_offset ge (Vptr b' ofs')) (Vptr b' ofs') + args (sig_args sig) t), + (* Check signature *) + forall (CALLSIG: Genv.type_of_call ge (comp_of f) (Genv.find_comp_ignore_offset ge (Vptr b' ofs')) = Genv.CrossCompartmentCall -> + (exists fd, Genv.find_funct_ptr ge b' = Some fd /\ sig = funsig fd)), + (* Check public symbols *) + forall (CHECKPUB: Genv.type_of_call ge (comp_of f) (Genv.find_comp_ignore_offset ge (Vptr b' ofs')) = Genv.CrossCompartmentCall -> + public_first_order ge m), + step_fix (State st rs m) t (State st' rs' m') +| exec_step_fix_internal_return: + forall b ofs f i rs m rs' cp m' st, + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_instr (Ptrofs.unsigned ofs) (fn_code f) = Some i -> + exec_instr f i rs m cp = Next rs' m' -> + is_return i = true -> + forall (CURCOMP: Genv.find_comp_ignore_offset ge (rs PC) = cp), + (* We attempt a return, so we go to a ReturnState*) + (* The only condition is the following: we are currently in the compartment stored in the callee compartment field + of the top stack frame*) + forall (REC_CURCOMP: Genv.find_comp_ignore_offset ge (rs PC) = callee_comp st), + (* forall (NEXTCOMP: Genv.find_comp_ignore_offset ge (rs' PC) = cp'), *) + step_fix (State st rs m) E0 (ReturnState st rs' m') +| exec_step_fix_return: + forall st st' rs m sg t rec_cp rec_cp' cp', + rs PC <> Vnullptr -> (* this condition is there to stop the execution 1 step_fix earlier, to make the proof easier *) + forall (REC_CURCOMP: callee_comp st = rec_cp), + forall (REC_NEXTCOMP: call_comp st = rec_cp'), + forall (NEXTCOMP: Genv.find_comp_ignore_offset ge (rs PC) = cp'), + (* We only impose conditions on when returns can be executed for cross-compartment + returns. These conditions are that we restore the previous RA and SP *) + forall (PC_RA: rec_cp <> cp' -> rs PC = asm_parent_ra st), + forall (RESTORE_SP: rec_cp <> cp' -> rs SP = asm_parent_sp st), + (* forall (RETURN_FROM_CP: cp <> cp' -> cp = callee_comp st), *) + (* Note that in the same manner, this definition only updates the stack when doing + cross-compartment returns *) + forall (STUPD: update_stack_return st rec_cp rs = Some st'), + (* We do not return a pointer *) + forall (SIG_STACK: sig_of_call st = sg), + forall (NO_CROSS_PTR: + (Genv.type_of_call ge cp' rec_cp = Genv.CrossCompartmentCall -> + not_ptr (return_value rs sg))), + forall (EV: return_trace ge cp' rec_cp (return_value rs sg) (sig_res sg) t), + (* Check public symbols *) + forall (CHECKPUB: Genv.type_of_call ge cp' rec_cp = Genv.CrossCompartmentCall -> + public_first_order ge m), + step_fix (ReturnState st rs m) t (State st' rs m) +| exec_step_fix_builtin: + forall b ofs f ef args res rs m vargs t vres rs' m' st, + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some (Pbuiltin ef args (map_builtin_res preg_of res)) -> + eval_builtin_args ge rs (rs SP) m args vargs -> + external_call ef ge vargs m t vres m' -> + forall (ALLOWED: comp_of ef = comp_of f), + rs' = nextinstr + (set_res (map_builtin_res preg_of res) vres + (undef_regs (map preg_of (destroyed_by_builtin ef)) + (rs #X1 <- Vundef #X31 <- Vundef))) -> + (* Limit leaks when calling unknown function *) + forall (ECC: external_call_conds ef ge m vargs), + step_fix (State st rs m) t (State st rs' m') +| exec_step_fix_external: + forall b ef args res rs m t rs' m' st, + rs PC = Vptr b Ptrofs.zero -> + Genv.find_funct_ptr ge b = Some (External ef) -> + (* forall COMP: Genv.find_comp_ignore_offset ge (rs RA) = cp, (* compartment that is calling the external function *) *) + external_call ef ge args m t res m' -> + extcall_arguments rs m (ef_sig ef) args -> + rs' = (set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs))#PC <- (rs RA) -> + (* These steps behave like returns. So we do the same as in the [exec_step_internal_return] case. *) + forall (REC_CURCOMP: Genv.find_comp_ignore_offset ge (rs PC) = callee_comp st), + (* Limit leaks when calling unknown function *) + forall (ECC: external_call_conds ef ge m args), + step_fix (State st rs m) t (ReturnState st rs' m'). + End RELSEM. (** Execution of whole programs. *) diff --git a/riscV/Asmgenproof.v b/riscV/Asmgenproof.v index dfcf877ce4..80b189c615 100644 --- a/riscV/Asmgenproof.v +++ b/riscV/Asmgenproof.v @@ -30,6 +30,14 @@ Proof. now inv EQ0. Qed. +Instance external_transf_fundef: is_external_transl_partial transf_fundef. +Proof. + unfold transf_fundef, transf_function, transl_function. + intros [f | ef] ? ? H; monadInv H; trivial. + destruct transl_code'; simpl in *; try easy. + reflexivity. +Qed. + Lemma transf_program_match: forall p tp, transf_program p = OK tp -> match_prog p tp. Proof. diff --git a/security/Backtranslation.v b/security/Backtranslation.v index f87495e928..b73e454228 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -4,216 +4,627 @@ Require Import AST Linking Smallstep Events Behaviors. Require Import Split. +Require Import Tactics. +Require Import riscV.Asm. +Require Import BtBasics BtInfoAsm MemoryDelta MemoryWeak. Require Import Ctypes Clight. -Record backtranslation_environment := - { local_counter: compartment -> ident }. -Section Backtranslation. - Variable bt_env: backtranslation_environment. +Ltac simpl_expr := + repeat (match goal with + | |- eval_expr _ _ _ _ _ _ _ => econstructor + | |- eval_lvalue _ _ _ _ _ _ _ _ _ => econstructor 2 + (* | |- eval_lvalue _ _ _ _ _ _ _ _ _ => econstructor *) + | |- deref_loc _ _ _ _ _ _ _ => econstructor + | |- assign_loc _ _ _ _ _ _ _ _ _ => econstructor + | |- Cop.sem_cmp _ _ _ _ _ _ = Some _ => unfold Cop.sem_cmp + | |- Cop.sem_add _ _ _ _ _ _ = Some _ => unfold Cop.sem_add + | |- Cop.sem_binarith _ _ _ _ _ _ _ _ _ = Some _ => unfold Cop.sem_binarith + | |- match Cop.sem_cast _ ?x ?x _ with | _ => _ end = Some _ => rewrite Cop.cast_val_casted + | |- Cop.sem_cast _ ?y ?y _ = Some _ => rewrite Cop.cast_val_casted + | |- Cop.val_casted _ _ => constructor + | H: ?x = _ |- Cop.bool_val (_ ?x) _ _ = Some _ => rewrite H; try reflexivity + end; simpl; eauto). - Definition ptr_of_id_ofs (id: ident) (ofs: ptrofs): expr := - Ebinop Cop.Oadd - (Eaddrof (Evar id Tvoid) (Tpointer Tvoid noattr)) - (Econst_int (Ptrofs.to_int ofs) (Tint I32 Signed noattr)) - (Tpointer Tvoid noattr). - - Fixpoint list_eventval_to_typelist (vs: list eventval): typelist := - match vs with - | nil => Tnil - | cons v vs' => Tcons Tvoid (list_eventval_to_typelist vs') - end. (* TODO: currently this is just a list of Tvoid of the right size. Fix? *) - - Definition eventval_to_expr (v: eventval): expr := - match v with - | EVint i => Econst_int i (Tint I32 Signed noattr) - | EVlong i => Econst_long i (Tlong Signed noattr) - | EVfloat f => Econst_float f (Tfloat F32 noattr) - | EVsingle f => Econst_single f (Tfloat F32 noattr) - | EVptr_global id ofs => Ebinop Cop.Oadd - (Eaddrof (Evar id Tvoid) (Tpointer Tvoid noattr)) - (Econst_int (Ptrofs.to_int ofs) (Tint I32 Signed noattr)) - (Tpointer Tvoid noattr) - end. - - Definition list_eventval_to_list_expr (vs: list eventval): list expr := - List.map eventval_to_expr vs. - - (* An [event_syscall] does not need any code, because it is only generated after a call to an external function *) - Definition code_of_syscall (name: string) (vs: list eventval) (v: eventval) := Sskip. - - Definition code_of_vload (ch: memory_chunk) (id: ident) (ofs: Ptrofs.int) (v: eventval) := - Sbuiltin None (EF_vload ch) (Tcons (Tpointer Tvoid noattr) Tnil) (ptr_of_id_ofs id ofs :: nil). - - Definition code_of_vstore (ch: memory_chunk) (id: ident) (ofs: Ptrofs.int) (v: eventval) := - Sbuiltin None (EF_vstore ch) (Tcons (Tpointer Tvoid noattr) Tnil) (ptr_of_id_ofs id ofs :: nil). +Ltac take_step := econstructor; [econstructor; simpl_expr | | traceEq]; simpl. - Definition code_of_annot (str: string) (vs: list eventval) := - Sbuiltin None (EF_annot - (Pos.of_nat (List.length (typlist_of_typelist (list_eventval_to_typelist vs)))) - str - (typlist_of_typelist (list_eventval_to_typelist vs)) - ) (list_eventval_to_typelist vs) - (list_eventval_to_list_expr vs). - Definition code_of_call (cp cp': compartment) (id: ident) (vs: list eventval) := - Scall None (Evar id (Tfunction (list_eventval_to_typelist vs) Tvoid cc_default)) (list_eventval_to_list_expr vs). - - Definition code_of_return (cp cp': compartment) (v: eventval) := - Sreturn (Some (eventval_to_expr v)). - - Definition code_of_event (e: event): statement := - match e with - | Event_syscall name vs v => code_of_syscall name vs v - | Event_vload ch id ofs v => code_of_vload ch id ofs v - | Event_vstore ch id ofs v => code_of_vstore ch id ofs v - | Event_annot str vs => code_of_annot str vs - | Event_call cp cp' id vs => code_of_call cp cp' id vs - | Event_return cp cp' v => code_of_return cp cp' v - end. +Section SWITCH. + (** switch statement; used when converting a trace to a code **) - Definition type_counter: type := Tint I32 Unsigned noattr. + Definition type_counter: type := Tlong Unsigned noattr. Definition type_bool: type := Tint IBool Signed noattr. - Definition switch_clause (cp: compartment) (n: Z) (s_then s_else: statement): statement := - let one := Econst_int (Int.repr 1%Z) (Tint I32 Unsigned noattr) in + Definition switch_clause (cnt: ident) (n: Z) (s_then s_else: statement): statement := + let one := Econst_long Int64.one type_counter in Sifthenelse (Ebinop Cop.Oeq - (Evar (bt_env.(local_counter) cp) type_counter) - (Econst_int (Int.repr n) (Tint I32 Unsigned noattr)) type_bool) + (Evar cnt type_counter) + (Econst_long (Int64.repr n) type_counter) + type_bool) (* if true *) (Ssequence - (Sassign (Evar (bt_env.(local_counter) cp) type_counter) - (Ebinop Cop.Oadd (Evar (bt_env.(local_counter) cp) type_counter) one type_counter)) + (Sassign (Evar cnt type_counter) + (Ebinop Cop.Oadd (Evar cnt type_counter) one type_counter)) s_then) (* if false *) s_else. - Ltac simpl_expr := - unfold type_counter; unfold type_bool; simpl; - repeat (match goal with - | |- eval_expr _ _ _ _ _ _ _ => econstructor - | |- eval_lvalue _ _ _ _ _ _ _ _ _ => econstructor - | |- deref_loc _ _ _ _ _ _ _ => econstructor - | |- assign_loc _ _ _ _ _ _ _ _ _ => econstructor - | |- Cop.sem_cmp _ _ _ _ _ _ = Some _ => unfold Cop.sem_cmp - | |- Cop.sem_add _ _ _ _ _ _ = Some _ => unfold Cop.sem_add - | |- Cop.sem_binarith _ _ _ _ _ _ _ _ _ = Some _ => unfold Cop.sem_binarith - | |- match Cop.sem_cast _ ?x ?x _ with | _ => _ end = Some _ => rewrite Cop.cast_val_casted - | |- Cop.sem_cast _ ?y ?y _ = Some _ => rewrite Cop.cast_val_casted - | |- Cop.val_casted _ _ => constructor - | H: ?x = _ |- Cop.bool_val (_ ?x) _ _ = Some _ => rewrite H; try reflexivity - end; simpl; eauto). - - Ltac take_step := econstructor; [econstructor; simpl_expr | | traceEq]; simpl. - - Lemma switch_clause_spec p (cp: compartment) f (e: env) le m b (n: int) (n': Z) s_then s_else: - cp = comp_of f -> - e ! (bt_env.(local_counter) cp) = Some (b, type_counter) -> - Mem.valid_access m Mint32 b 0 Writable (Some cp) -> - Mem.loadv Mint32 m (Vptr b Ptrofs.zero) (Some cp) = Some (Vint n) -> - if Int.eq n (Int.repr n') then + Ltac simpl_expr' := + unfold type_counter; unfold type_bool; simpl; simpl_expr. + + Ltac take_step' := econstructor; [econstructor; simpl_expr' | | traceEq]; simpl. + + Lemma switch_clause_spec (ge: genv) (cnt: ident) f e le m b k (n: int64) (n': Z) s_then s_else: + let cp := comp_of f in + e ! cnt = None -> + Genv.find_symbol ge cnt = Some b -> + Mem.valid_access m Mint64 b 0 Writable (Some cp) -> + Mem.loadv Mint64 m (Vptr b Ptrofs.zero) (Some cp) = Some (Vlong n) -> + if Int64.eq n (Int64.repr n') then exists m', - Mem.storev Mint32 m (Vptr b Ptrofs.zero) (Vint (Int.add n Int.one)) cp = Some m' /\ - (* Memory.store mem (C, Block.local, 0%Z) (Int (Z.succ n)) = Some mem' /\ *) - Star (Clight.semantics1 p) (State f (switch_clause cp n' s_then s_else) Kstop e le m) E0 (State f s_then Kstop e le m') + Mem.storev Mint64 m (Vptr b Ptrofs.zero) (Vlong (Int64.add n Int64.one)) cp = Some m' /\ + star (step1) ge (State f (switch_clause cnt n' s_then s_else) k e le m) E0 (State f s_then k e le m') else - Star (Clight.semantics1 p) (State f (switch_clause cp n' s_then s_else) Kstop e le m) E0 (State f s_else Kstop e le m). - Proof. - intros; subst cp. - destruct (Int.eq n (Int.repr n')) eqn:eq_n_n'. - - simpl. - destruct (Mem.valid_access_store m Mint32 b 0%Z (comp_of f) (Vint (Int.add n Int.one))) as [m' m_m']; try assumption. - exists m'. split; eauto. - do 4 take_step. - now apply star_refl. - - (* take_steps. *) - take_step. rewrite Int.eq_true; simpl. - now apply star_refl. - Qed. - - Definition switch_add_statement cp s res := - (Z.pred (fst res), switch_clause cp (Z.pred (fst res)) s (snd res)). - - Definition switch (cp: compartment) (ss: list statement) (s_else: statement): statement := - snd (fold_right (switch_add_statement cp) (Z.of_nat (length ss), s_else) ss). - - Lemma fst_switch (cp: compartment) n (s_else: statement) (ss : list statement) : - fst (fold_right (switch_add_statement cp) (n, s_else) ss) = (n - Z.of_nat (length ss))%Z. + star (step1) ge (State f (switch_clause cnt n' s_then s_else) k e le m) E0 (State f s_else k e le m). + Proof. + intros; subst cp. + destruct (Int64.eq n (Int64.repr n')) eqn:eq_n_n'. + - simpl. + destruct (Mem.valid_access_store m Mint64 b 0%Z (comp_of f) (Vlong (Int64.add n Int64.one))) as [m' m_m']; try assumption. + exists m'. split; eauto. + do 4 take_step'. + now apply star_refl. + - (* take_steps. *) + take_step'. rewrite Int.eq_true; simpl. + now apply star_refl. + Qed. + + + Definition switch_add_statement cnt s res := + (Z.pred (fst res), switch_clause cnt (Z.pred (fst res)) s (snd res)). + + Definition switch (cnt: ident) (ss: list statement) (s_else: statement): statement := + snd (fold_right (switch_add_statement cnt) (Z.of_nat (length ss), s_else) ss). + + Lemma fst_switch (cnt: ident) n (s_else: statement) (ss : list statement) : + fst (fold_right (switch_add_statement cnt) (n, s_else) ss) = (n - Z.of_nat (length ss))%Z. Proof. induction ss as [|s' ss IH]; try now rewrite Z.sub_0_r. simpl; lia. Qed. - Lemma switch_spec_else p (cp: compartment) f Kstop (e: env) le m b (n: Z) ss s_else: - n >= 0 -> - cp = comp_of f -> - e ! (bt_env.(local_counter) cp) = Some (b, type_counter) -> - Mem.valid_access m Mint32 b 0 Writable (Some cp) -> - Mem.loadv Mint32 m (Vptr b Ptrofs.zero) (Some cp) = Some (Vint (Int.repr n)) -> - (Z.of_nat (length ss) <= n)%Z -> - Star (Clight.semantics1 p) - (State f (switch cp ss s_else) Kstop e le m) + Lemma switch_spec_else + (ge: genv) (cnt: ident) f (e: env) le m b k (n: Z) ss s_else + (WF: Z.of_nat (length ss) < Int64.modulus) + (RANGE: Z.of_nat (length ss) <= n < Int64.modulus) + : + let cp := comp_of f in + e ! cnt = None -> + Genv.find_symbol ge cnt = Some b -> + Mem.loadv Mint64 m (Vptr b Ptrofs.zero) (Some cp) = Some (Vlong (Int64.repr n)) -> + star (step1) ge + (State f (switch cnt ss s_else) k e le m) E0 - (State f s_else Kstop e le m). + (State f s_else k e le m). Proof. - intros; subst cp. unfold switch. + intros; subst cp. unfold switch. destruct RANGE as [RA1 RA2]. assert (G: forall n', - 0 <= n' -> + (Z.of_nat (length ss)) <= n' -> n' <= n -> - Z.of_nat (length ss) <= n -> - Star (Clight.semantics1 p) - (State f (snd (fold_right (switch_add_statement (comp_of f)) (n', s_else) ss)) Kstop e le m) - E0 - (State f s_else Kstop e le m)). - { clear H4. - intros n' zero_le_n' n'_le_n' ss_le_n. + star (step1) ge + (State f (snd (fold_right (switch_add_statement cnt) (n', s_else) ss)) k e le m) + E0 + (State f s_else k e le m)). + { intros n' LE1 LE2. induction ss as [|s ss IH]; try apply star_refl. - simpl. simpl in ss_le_n. rewrite fst_switch, <- Z.sub_succ_r. - take_step. - { rewrite Int.eq_false. reflexivity. + simpl. simpl in RA1, LE1. rewrite fst_switch, <- Z.sub_succ_r. + take_step'. + { rewrite Int64.eq_false. reflexivity. clear - WF RA1 RA2 LE1 LE2. destruct (Z.eqb_spec n (n' - Z.of_nat (S (length ss)))) as [n_eq_0|?]; simpl. - lia. - - (* I think it's not always true. Might need restricton on [n] fitting in 32 bits? *) - admit. } + - intros EQ. apply n0; clear n0. + rewrite <- (Int64.unsigned_repr n). + rewrite EQ. rewrite Int64.unsigned_repr. lia. + 1: split. + all: unfold Int64.max_unsigned; try lia. + } rewrite Int.eq_true; simpl. - eapply IH. lia. } + eapply IH; lia. + } now apply G; lia. - Admitted. + Qed. + + Definition nat64 n := Int64.repr (Z.of_nat n). + + Lemma switch_spec + (ge: genv) (cnt: ident) f (e: env) le m b k + ss s ss' s_else + (WF: Z.of_nat (length (ss ++ s :: ss')) < Int64.modulus) + : + let cp := comp_of f in + e ! cnt = None -> + Genv.find_symbol ge cnt = Some b -> + Mem.valid_access m Mint64 b 0 Writable (Some cp) -> + Mem.loadv Mint64 m (Vptr b Ptrofs.zero) (Some cp) = Some (Vlong (nat64 (length ss))) -> + exists m', + Mem.storev Mint64 m (Vptr b Ptrofs.zero) (Vlong (Int64.add (nat64 (length ss)) Int64.one)) cp = Some m' /\ + star (step1) ge + (State f (switch cnt (ss ++ s :: ss') s_else) k e le m) + E0 + (State f s k e le m'). + Proof. + intros. + assert (Eswitch : + exists s_else', + switch cnt (ss ++ s :: ss') s_else = + switch cnt ss (switch_clause cnt (Z.of_nat (length ss)) s s_else')). + { unfold switch. rewrite fold_right_app, app_length. simpl. + exists (snd (fold_right (switch_add_statement cnt) (Z.of_nat (length ss + S (length ss')), s_else) ss')). + repeat f_equal. rewrite -> surjective_pairing at 1. simpl. + rewrite fst_switch, Nat.add_succ_r. + assert (A: Z.pred (Z.of_nat (S (Datatypes.length ss + Datatypes.length ss')) - Z.of_nat (Datatypes.length ss')) = Z.of_nat (Datatypes.length ss)) by lia. + rewrite A. reflexivity. + } + destruct Eswitch as [s_else' ->]. clear s_else. rename s_else' into s_else. + exploit (switch_clause_spec ge cnt f e le m b k (nat64 (length ss)) (Z.of_nat (length ss)) s s_else); auto. + unfold nat64. rewrite Int64.eq_true. intro Hcont. + destruct Hcont as (m' & Hstore & Hstar2). + exists m'. split; trivial. + apply (fun H => @star_trans _ _ _ _ _ E0 _ H E0 _ _ Hstar2); trivial. + assert (WF2: Z.of_nat (Datatypes.length ss) < Int64.modulus). + { clear - WF. rewrite app_length in WF. lia. } + eapply switch_spec_else; eauto. split; auto. reflexivity. + Qed. + +End SWITCH. + +Section CONV. + (** converting event to data **) - Section WithTrace. + Variable ge: Senv.t. - Variable cp: compartment. - Variable t: trace. - (* Hypothesis t_cp: forall e \in t, comp_of e = cp. *) - (* Hypothesis t_small_enoug: length t <= 2^60. *) + Definition not_in_env (e: env) id := e ! id = None. - Definition statement_of_trace: statement := - switch (map (statement_of_event cp) t) Sskip. + Definition wf_env (e: env) := + forall id, match Senv.find_symbol ge id with + | Some _ => not_in_env e id + | _ => True + end. + + Definition eventval_to_val (v: eventval): val := + match v with + | EVint i => Vint i + | EVlong i => Vlong i + | EVfloat f => Vfloat f + | EVsingle f => Vsingle f + | EVptr_global id ofs => match Senv.find_symbol ge id with + | Some b => Vptr b ofs + | None => Vundef + end + end. + + Definition list_eventval_to_list_val (vs: list eventval): list val := + List.map (eventval_to_val) vs. + + Definition eventval_to_type (v: eventval): type := + match v with + | EVint _ => Tint I32 Signed noattr + | EVlong _ => Tlong Signed noattr + | EVfloat _ => Tfloat F64 noattr + | EVsingle _ => Tfloat F32 noattr + | EVptr_global id _ => Tpointer Tvoid noattr + end. + Fixpoint list_eventval_to_typelist (vs: list eventval): typelist := + match vs with + | nil => Tnil + | cons v vs' => Tcons (eventval_to_type v) (list_eventval_to_typelist vs') + end. + Definition ptr_of_id_ofs (id: ident) (ofs: ptrofs): expr := + if Archi.ptr64 + then + Ebinop Cop.Oadd + (Eaddrof (Evar id Tvoid) (Tpointer Tvoid noattr)) + (Econst_long (Ptrofs.to_int64 ofs) (Tlong Signed noattr)) + (Tpointer Tvoid noattr) + else + Ebinop Cop.Oadd + (Eaddrof (Evar id Tvoid) (Tpointer Tvoid noattr)) + (Econst_int (Ptrofs.to_int ofs) (Tint I32 Signed noattr)) + (Tpointer Tvoid noattr). - End WithTrace. + Lemma ptr_of_id_ofs_typeof + i i0 + : + typeof (ptr_of_id_ofs i i0) = Tpointer Tvoid noattr. + Proof. unfold ptr_of_id_ofs. destruct Archi.ptr64; simpl; auto. Qed. -End Backtranslation. + Definition eventval_to_expr (v: eventval): expr := + match v with + | EVint i => Econst_int i (Tint I32 Signed noattr) + | EVlong i => Econst_long i (Tlong Signed noattr) + | EVfloat f => Econst_float f (Tfloat F64 noattr) + | EVsingle f => Econst_single f (Tfloat F32 noattr) + | EVptr_global id ofs => ptr_of_id_ofs id ofs + end. - (* Axiom backtranslation: Policy.t -> split -> trace -> Csyntax.program * Csyntax.program. *) - (* Axiom backtranslation_correct: *) - (* forall pol s t p C, *) - (* backtranslation pol s t = (p, C) -> *) - (* c_compatible s p C /\ *) - (* exists W, link p C = Some W /\ *) - (* c_program_has_initial_trace W t. *) + Definition list_eventval_to_list_expr (vs: list eventval): list expr := + List.map eventval_to_expr vs. - (* Axiom backtranslation_compiles: *) - (* forall pol s t p C, *) - (* backtranslation pol s t = (p, C) -> *) - (* exists p_compiled C_compiled, *) - (* transf_c_program p = OK p_compiled /\ *) - (* transf_c_program C = OK C_compiled. *) + Lemma typeof_eventval_to_expr_type + v + : + typeof (eventval_to_expr v) = eventval_to_type v. + Proof. destruct v; simpl; auto. apply ptr_of_id_ofs_typeof. Qed. + + Definition wf_eventval_pub (v: eventval): Prop := + match v with + | EVptr_global id _ => (Senv.public_symbol ge id = true) + | _ => True + end. + +End CONV. + + +Section CODEAUX. + + (* We extract function data: argument types, fn_return, rn_callconv from signature *) + (* Correctness should follow from eventval_match *) + Definition typ_to_type: typ -> type := + fun t: typ => + match t with + | AST.Tint => Tint I32 Signed noattr + | AST.Tfloat => Tfloat F64 noattr + | AST.Tlong => Tlong Signed noattr + | AST.Tsingle => Tfloat F32 noattr + (* do not appear in eventval_match *) + | AST.Tany32 => Tint I32 Signed noattr + | AST.Tany64 => Tlong Signed noattr + end. + + Fixpoint list_typ_to_typelist (ts: list typ): typelist := + match ts with + | nil => Tnil + | cons t ts' => Tcons (typ_to_type t) (list_typ_to_typelist ts') + end. + + Definition rettype_to_type: rettype -> type := + fun rt: rettype => + match rt with + | Tint8signed | Tint8unsigned | Tint16signed | Tint16unsigned => Tint I32 Signed noattr + | AST.Tvoid => Tint I32 Signed noattr + | Tret t => typ_to_type t + end. + + Lemma proj_rettype_to_type_rettype_of_type_eq + ge evres rt res + (EVM: eventval_match ge evres (proj_rettype rt) res) + : + proj_rettype (rettype_of_type (rettype_to_type rt)) = proj_rettype rt. + Proof. + inv EVM; destruct rt; simpl; auto. + destruct t; simpl in *; auto; try congruence. + destruct t; simpl in *; auto; try congruence. + destruct t; simpl in *; auto; try congruence. + destruct t; simpl in *; auto; try congruence. + unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. + destruct t; simpl in *; auto; try congruence. + destruct t; simpl in *; auto; try congruence. + Qed. + + (* Wanted internal function data from signature *) + Record fun_data : Type := mkfundata { dargs: typelist; dret: type; dcc: calling_convention }. + Definition funs_data : Type := (PTree.tree fun_data). + + Definition from_sig_fun_data (sig: signature): fun_data := + mkfundata (list_typ_to_typelist sig.(sig_args)) (rettype_to_type sig.(sig_res)) (sig.(sig_cc)). + + (* Extract from Asm *) + Definition from_asmfun_fun_data (af: Asm.function): fun_data := from_sig_fun_data af.(fn_sig). + Definition from_extfun_fun_data (ef: external_function): fun_data := from_sig_fun_data (ef_sig ef). + Definition from_asmfd_fun_data (fd: Asm.fundef): fun_data := + match fd with | AST.Internal af => from_asmfun_fun_data af | AST.External ef => from_extfun_fun_data ef end. + Definition from_asmgd_fun_data (gd: globdef Asm.fundef unit): option fun_data := + match gd with | Gfun fd => Some (from_asmfd_fun_data fd) | Gvar _ => None end. + + Definition from_asm_funs_data (asm: Asm.program): funs_data := + let defs := Genv.genv_defs (Genv.globalenv asm) in + PTree.map_filter1 from_asmgd_fun_data defs. + + (* Extract from Clight *) + Definition from_clfun_fun_data (cf: Clight.function): fun_data := mkfundata (type_of_params cf.(fn_params)) cf.(fn_return) cf.(fn_callconv). + Definition from_clfd_fun_data (fd: Clight.fundef): fun_data := + match fd with | Ctypes.Internal cf => from_clfun_fun_data cf | Ctypes.External ef _ _ _ => from_extfun_fun_data ef end. + Definition from_clgd_fun_data (gd: globdef Clight.fundef type): option fun_data := + match gd with | Gfun fd => Some (from_clfd_fun_data fd) | Gvar _ => None end. + + Definition from_cl_funs_data (cl: Clight.program): funs_data := + let defs := Genv.genv_defs (genv_genv (globalenv cl)) in + PTree.map_filter1 from_clgd_fun_data defs. + +End CODEAUX. + + +Section CONV. + + Variable ge: Senv.t. + + (* Type: Tvoid has size 1, which is what we want *) + Definition expr_of_addr (id: ident) (ofs: ptrofs): expr := + ptr_of_id_ofs id ofs. + + Definition chunk_to_type (ch: memory_chunk): option type := + match ch with + | Mint8signed => Some (Tint I8 Signed noattr) + | Mint8unsigned => Some (Tint I8 Unsigned noattr) + | Mint16signed => Some (Tint I16 Signed noattr) + | Mint16unsigned => Some (Tint I16 Unsigned noattr) + | Mint32 => Some (Tint I32 Signed noattr) + | Mint64 => Some (Tlong Signed noattr) + | Mfloat32 => Some (Tfloat F32 noattr) + | Mfloat64 => Some (Tfloat F64 noattr) + | Many32 => None + | Many64 => None + end. + + Lemma access_mode_chunk_to_type_wf + ch ty + (CT: chunk_to_type ch = Some ty) + : + access_mode ty = By_value ch. + Proof. destruct ch; inv CT; ss. Qed. + + Definition chunk_val_to_expr (ch: memory_chunk) (v: val) : option expr := + match chunk_to_type ch with + | Some ty => + match v with + | Vint i => Some (Econst_int i ty) + | Vlong i => Some (Econst_long i ty) + | Vfloat f => Some (Econst_float f ty) + | Vsingle f => Some (Econst_single f ty) + | Vptr b ofs => + match Senv.invert_symbol ge b with + | Some id => Some (ptr_of_id_ofs id ofs) + | None => None + end + | Vundef => None + end + | None => None + end. + +End CONV. + + +Section CODE. + (** converting *informative* trace to code **) + + Variable ge: Senv.t. + + Definition code_mem_delta_storev cp0 (d: mem_delta_storev): statement := + let '(ch, ptr, v, cp) := d in + match ptr with + | Vptr b ofs => + match Senv.invert_symbol ge b with + | Some id => + match chunk_to_type ch, chunk_val_to_expr ge ch v with + | Some ty, Some ve => + if ((Senv.public_symbol ge id) && (wf_chunk_val_b ch v) && (cp0 =? cp)%positive) + then Sassign (Ederef (expr_of_addr id ofs) ty) ve + else Sskip + | _, _ => Sskip + end + | None => Sskip + end + | _ => Sskip + end. + + Definition code_mem_delta_kind cp (d: mem_delta_kind): statement := + match d with + | mem_delta_kind_storev dd => code_mem_delta_storev cp dd + | _ => Sskip + end. + + Definition code_mem_delta cp (d: mem_delta) (snext: statement): statement := + fold_right Ssequence snext (map (code_mem_delta_kind cp) d). + + Definition code_bundle_call cp (tr: trace) (id: ident) (evargs: list eventval) (sg: signature) (d: mem_delta): statement := + let tys := from_sig_fun_data sg in + code_mem_delta cp d (Scall None (Evar id (Tfunction tys.(dargs) tys.(dret) tys.(dcc))) (list_eventval_to_list_expr evargs)). + + Definition code_bundle_return cp (tr: trace) (evr: eventval) (d: mem_delta): statement := + code_mem_delta cp d (Sreturn (Some (eventval_to_expr evr))). + + Definition code_bundle_builtin cp (tr: trace) (ef: external_function) (evargs: list eventval) (d: mem_delta): statement := + code_mem_delta cp d (Sbuiltin None ef (list_eventval_to_typelist evargs) (list_eventval_to_list_expr evargs)). + + Definition code_bundle_event cp (be: bundle_event): statement := + match be with + | Bundle_call tr id evargs sg d => code_bundle_call cp tr id evargs sg d + | Bundle_return tr evr d => code_bundle_return cp tr evr d + | Bundle_builtin tr ef evargs d => code_bundle_builtin cp tr ef evargs d + end. + + Definition one_expr: expr := Econst_int Int.one (Tint I32 Signed noattr). + + Definition switch_bundle_events cnt cp (tr: bundle_trace) := + switch cnt (map (fun ib => code_bundle_event cp (snd ib)) tr) (Sreturn None). + + (* A while(1)-loop with big if-then-elses inside it *) + Definition code_bundle_trace cp (cnt: ident) (tr: bundle_trace): statement := + Swhile one_expr (switch_bundle_events cnt cp tr). + +End CODE. + +Section GEN. + + Definition list_typ_to_list_type (ts: list typ): list type := map typ_to_type ts. + + Definition gen_function (ge: Senv.t) (cnt: ident) (params: list (ident * type)) (tr: bundle_trace) (a_f: Asm.function): function := + let a_sg := Asm.fn_sig a_f in + let tret := rettype_to_type a_sg.(sig_res) in + let cc := a_sg.(sig_cc) in + let cp := Asm.fn_comp a_f in + mkfunction cp + tret + cc + params + [] + [] + (code_bundle_trace ge cp cnt tr). + + Definition gen_fundef (ge: Senv.t) (cnt: ident) params (tr: bundle_trace) (a_fd: Asm.fundef): Clight.fundef := + match a_fd with + | AST.Internal a_f => Internal (gen_function ge cnt params tr a_f) + | AST.External ef => + let dsg := from_sig_fun_data (ef_sig ef) in + External ef dsg.(dargs) dsg.(dret) dsg.(dcc) + end. + + Definition gen_globvar (gv: globvar unit): globvar type := + mkglobvar Tvoid gv.(gvar_comp) gv.(gvar_init) gv.(gvar_readonly) gv.(gvar_volatile). + + Definition default_globvar: globvar type := + mkglobvar Tvoid default_compartment [] false false. + + Definition gen_globdef ge cnt params tr (a_gd: globdef Asm.fundef unit): globdef Clight.fundef type := + match a_gd with + | Gfun a_fd => Gfun (gen_fundef ge cnt params tr a_fd) + | Gvar a_gv => Gvar (gen_globvar a_gv) + end. + + Definition gen_counter cp: globdef Clight.fundef type := + Gvar (mkglobvar type_counter cp [(Init_int64 Int64.zero)] false false). + + (* Generate the max + 1 of the keys *) + Definition next_id {A} (l: list (ident * A)): ident := + Pos.succ (fold_left (fun x '(i, _) => if (x (id, (Pos.add id m, gen_counter (comp_of gd)))) gds in + PTree_Properties.of_list gds'. + + Definition params_of := PTree.t (list (ident * type)). + + Fixpoint numbering {A} (i: ident) (l: list A): list (ident * A) := + match l with + | [] => [] + | hd :: tl => (i, hd) :: (numbering (Pos.succ i) tl) + end. + + Definition gen_params_one (m: ident) (gd: globdef Asm.fundef unit): option (list (ident * type)) := + match gd with + | Gvar _ => None + | Gfun fd => + let types := map typ_to_type (sig_args (funsig fd)) in + Some (numbering m types) + end. + + (* Generate fresh parameter ids for each function --- parameter ids for different functions are allowed to be duplicated *) + Definition gen_params (m: ident) (gds: list (ident * globdef Asm.fundef unit)): params_of := + let params' := map (fun '(id, gd) => match gen_params_one m gd with + | Some ps => (id, ps) + | None => (id, []) + end) gds + in + PTree_Properties.of_list params'. + + + Definition gen_progdef (ge: Senv.t) (tr: bundle_trace) a_gd (ocnt: option (ident * globdef Clight.fundef type)) (oparams: option (list (ident * type))): globdef Clight.fundef type := + match ocnt, oparams with + | Some (cnt, _), Some params => gen_globdef ge cnt params tr a_gd + | _, _ => Gvar default_globvar + end. + + Definition get_id_tr (tr: bundle_trace) (id0: ident): bundle_trace := filter (fun '(id, _) => Pos.eqb id0 id) tr. + + Definition gen_prog_defs (a_ge: Senv.t) tr (gds: list (ident * globdef Asm.fundef unit)): list (ident * globdef Clight.fundef type) := + let m0 := next_id gds in + let cnts := gen_counter_defs m0 gds in + let cnt_defs := map snd (PTree.elements cnts) in + let m1 := next_id cnt_defs in + let params := gen_params m1 gds in + (map (fun '(id, gd) => (id, gen_progdef a_ge (get_id_tr tr id) gd (cnts ! id) (params ! id))) gds) ++ cnt_defs. + + Program Definition gen_program tr (a_p: Asm.program): Clight.program := + let a_ge := Genv.globalenv a_p in + @Build_program _ + (gen_prog_defs a_ge tr a_p.(AST.prog_defs)) + (AST.prog_public a_p) + (AST.prog_main a_p) + (AST.prog_pol a_p) + [] + (@PTree.empty composite) + _. + +End GEN. + + +Section AUX. + + Definition wf_keys {A} (l: list (ident * A)) := list_norepet (map fst l). + + Definition wf_params_of (pars: params_of) := + (forall id params, (pars ! id = Some params) -> list_norepet (var_names params)). + + Definition wf_params_of_sig (pars: params_of) (ge: Asm.genv) := + forall b f id params, (Genv.find_funct_ptr ge b = Some f) -> (Genv.find_symbol ge id = Some b) -> (pars ! id = Some params) -> + (list_typ_to_list_type (sig_args (funsig f)) = map snd params). + + Definition wf_params_of_symb (pars: params_of) (ge: Clight.genv) := + forall id b, (Senv.find_symbol ge id = Some b) -> + forall fid ps, pars ! fid = Some ps -> ~ (In id (map fst ps)). + + Lemma get_id_tr_cons + id be tr + : + get_id_tr (be :: tr) id = if (Pos.eqb id (fst be)) then (be :: get_id_tr tr id) else (get_id_tr tr id). + Proof. unfold get_id_tr. ss. des_ifs; ss; clarify. Qed. + + Lemma get_id_tr_app + id tr1 tr2 + : + get_id_tr (tr1 ++ tr2) id = (get_id_tr tr1 id) ++ (get_id_tr tr2 id). + Proof. unfold get_id_tr. rewrite filter_app. auto. Qed. + + Lemma alloc_variables_wf_params_of_symb0 + ge cp e m params e' m' + (AE: alloc_variables ge cp e m params e' m') + (WFE: wf_env ge e) + (pars: params_of) + (WFP: wf_params_of_symb pars ge) + fid vars + (PAR: pars ! fid = Some vars) + (INCL: forall x, In x params -> In x vars) + : + wf_env ge e'. + Proof. + revert_until AE. induction AE; ii. + { eapply WFE. } + eapply IHAE. 3: eapply PAR. + 3:{ i. eapply INCL. ss. right; auto. } + 2: auto. + clear IHAE id0. unfold wf_env in *. i. specialize (WFE id0). des_ifs. + unfold not_in_env in *. specialize (WFP _ _ Heq _ _ PAR). + destruct (Pos.eqb_spec id id0). + 2:{ rewrite PTree.gso; auto. } + subst id0. exfalso. apply WFP; clear WFP. specialize (INCL (id, ty)). + replace id with (fst (id, ty)). 2: ss. apply in_map. apply INCL. ss. left; auto. + Qed. - (* Axiom backtranslation_pol: forall pol s t, *) - (* Ctypes.prog_pol (fst (backtranslation pol s t)) = pol /\ *) - (* Ctypes.prog_pol (snd (backtranslation pol s t)) = pol. *) + Lemma alloc_variables_wf_params_of_symb + ge cp m params e' m' + (AE: alloc_variables ge cp empty_env m params e' m') + (pars: params_of) + (WFP: wf_params_of_symb pars ge) + fid + (PAR: pars ! fid = Some params) + : + wf_env ge e'. + Proof. eapply alloc_variables_wf_params_of_symb0; eauto. ii. des_ifs. Qed. + +End AUX. diff --git a/security/BacktranslationAux.v b/security/BacktranslationAux.v new file mode 100644 index 0000000000..87a8697399 --- /dev/null +++ b/security/BacktranslationAux.v @@ -0,0 +1,2022 @@ +Require Import String. +Require Import Coqlib Maps Errors Integers Values Memory Globalenvs. +Require Import AST Linking Smallstep Events Behaviors. + +Require Import Split. + +Require Import Tactics. +Require Import riscV.Asm. +Require Import BtBasics BtInfoAsm MemoryDelta MemoryWeak. +Require Import Ctypes Clight. +Require Import Backtranslation. + + + +Section CODEPROOFS. + + Lemma ptr_of_id_ofs_eval + (ge: genv) id ofs e b cp le m + (GE1: wf_env ge e) + (GE2: Senv.find_symbol ge id = Some b) + : + eval_expr ge e cp le m (ptr_of_id_ofs id ofs) (Vptr b ofs). + Proof. + specialize (GE1 id). rewrite GE2 in GE1. + unfold ptr_of_id_ofs. destruct (Archi.ptr64) eqn:ARCH. + - eapply eval_Ebinop. eapply eval_Eaddrof. eapply eval_Evar_global; eauto. + simpl_expr. + simpl. simpl_expr. rewrite Ptrofs.mul_commut, Ptrofs.mul_one. rewrite Ptrofs.add_zero_l. + rewrite Ptrofs.of_int64_to_int64; auto. + - eapply eval_Ebinop. eapply eval_Eaddrof. eapply eval_Evar_global; eauto. + simpl_expr. + simpl. simpl_expr. rewrite Ptrofs.mul_commut, Ptrofs.mul_one. rewrite Ptrofs.add_zero_l. + erewrite Ptrofs.agree32_of_ints_eq; auto. apply Ptrofs.agree32_to_int; auto. + Qed. + + Lemma code_mem_delta_cons + (ge: Senv.t) cp k d sn + : + code_mem_delta ge cp (k :: d) sn = + Ssequence (code_mem_delta_kind ge cp k) (code_mem_delta ge cp d sn). + Proof. unfold code_mem_delta. ss. Qed. + + Lemma code_mem_delta_app + (ge: Senv.t) cp d1 d2 sn + : + code_mem_delta ge cp (d1 ++ d2) sn = (code_mem_delta ge cp d1 (code_mem_delta ge cp d2 sn)). + Proof. + revert sn d2. induction d1; intros; ss. + rewrite ! code_mem_delta_cons. erewrite IHd1. auto. + Qed. + + Lemma type_of_chunk_val_to_expr + (ge: Senv.t) ch ty v e + (WF: wf_chunk_val_b ch v) + (CT: chunk_to_type ch = Some ty) + (CVE: chunk_val_to_expr ge ch v = Some e) + : + typeof e = ty. + Proof. unfold chunk_val_to_expr in CVE. rewrite CT in CVE. des_ifs. Qed. + + Definition val_is_int (v: val) := (match v with | Vint _ => True | _ => False end). + Definition val_is_not_int (v: val) := (match v with | Vint _ => False | _ => True end). + + Lemma val_cases v: (val_is_int v) \/ (val_is_not_int v). + Proof. destruct v; ss; auto. Qed. + + Lemma sem_cast_chunk_val + (ge: Senv.t) m ch ty v e + (WF: wf_chunk_val_b ch v) + (CT: chunk_to_type ch = Some ty) + (CVE: chunk_val_to_expr ge ch v = Some e) + (NINT: val_is_not_int v) + : + Cop.sem_cast v (typeof e) ty m = Some v. + Proof. + erewrite type_of_chunk_val_to_expr; eauto. apply Cop.cast_val_casted. clear - WF CT NINT. + unfold wf_chunk_val_b, wf_chunk_val_b in WF. des_ifs; ss; inv CT; econs. + Qed. + + Definition cast_chunk_int (ch: memory_chunk) (i: int): val := + match ch with + | Mint8signed => Vint (Int.sign_ext 8 i) + | Mint8unsigned => Vint (Int.zero_ext 8 i) + | Mint16signed => Vint (Int.sign_ext 16 i) + | Mint16unsigned => Vint (Int.zero_ext 16 i) + | Mint32 => Vint i + | _ => Vundef + end. + + Lemma chunk_val_to_expr_eval + (ge: genv) ch v exp e cp le m + (EXP: chunk_val_to_expr ge ch v = Some exp) + (WF: wf_chunk_val_b ch v) + : + eval_expr ge e cp le m exp v. + Proof. unfold chunk_val_to_expr in EXP. des_ifs; ss; econs. Qed. + + Lemma wf_chunk_val_chunk_to_type + ch v + (WF: wf_chunk_val_b ch v) + : + exists ty, chunk_to_type ch = Some ty. + Proof. unfold wf_chunk_val_b in WF. des_ifs; ss; eauto. Qed. + + Lemma wf_chunk_val_chunk_val_to_expr + (ge: Senv.t) ch v + (WF: wf_chunk_val_b ch v) + : + exists ve, chunk_val_to_expr ge ch v = Some ve. + Proof. + unfold chunk_val_to_expr. exploit wf_chunk_val_chunk_to_type; eauto. + intros (ty & TY). rewrite TY. unfold wf_chunk_val_b in WF. des_ifs; ss; eauto. + Qed. + + Lemma code_mem_delta_storev_correct + (ge: genv) f k e le m m' + d + (WFE: wf_env ge e) + (STORE: mem_delta_apply_storev (Some m) d = Some m') + (WF: wf_mem_delta_storev_b ge (comp_of f) d) + : + step1 ge (State f (code_mem_delta_storev ge (comp_of f) d) k e le m) + E0 (State f Sskip k e le m'). + Proof. + unfold wf_mem_delta_storev_b in WF. des_ifs. rename m0 into ch, i into ofs. ss. + exploit wf_chunk_val_chunk_to_type; eauto. intros (ty & TY). + exploit wf_chunk_val_chunk_val_to_expr; eauto. intros (ve & EXPR). + rewrite H, Heq, TY, EXPR. + destruct (val_cases v) as [INT | NINT]. + { unfold val_is_int in INT. des_ifs. clear INT. eapply step_assign. + - econs. unfold expr_of_addr. eapply ptr_of_id_ofs_eval; auto. + eapply Genv.invert_find_symbol; eauto. + - instantiate (1:=Vint i). eapply chunk_val_to_expr_eval; eauto. + - instantiate (1:=cast_chunk_int ch i). erewrite type_of_chunk_val_to_expr; eauto. + unfold chunk_to_type in TY. destruct ch; ss; inv TY. + + unfold Cop.sem_cast. ss. des_ifs. + + unfold Cop.sem_cast. ss. des_ifs. + + unfold Cop.sem_cast. ss. des_ifs. + + unfold Cop.sem_cast. ss. des_ifs. + + unfold Cop.sem_cast. ss. des_ifs. + - simpl_expr. eapply access_mode_chunk_to_type_wf; eauto. + rewrite <- STORE. apply Pos.eqb_eq in WF. subst c. destruct ch; ss. + + rewrite Mem.store_int8_sign_ext. auto. + + rewrite Mem.store_int8_zero_ext. auto. + + rewrite Mem.store_int16_sign_ext. auto. + + rewrite Mem.store_int16_zero_ext. auto. + } + { rewrite WF, H0. ss. eapply step_assign. + - econs. unfold expr_of_addr. eapply ptr_of_id_ofs_eval; auto. + eapply Genv.invert_find_symbol; eauto. + - instantiate (1:=v). eapply chunk_val_to_expr_eval; eauto. + - ss. eapply sem_cast_chunk_val; eauto. + - simpl_expr. eapply access_mode_chunk_to_type_wf; eauto. + apply Pos.eqb_eq in WF. clarify. + } + Qed. + + Lemma wf_mem_delta_storev_false_is_skip + (ge: Senv.t) cp d + (NWF: wf_mem_delta_storev_b ge cp d = false) + : + code_mem_delta_storev ge cp d = Sskip. + Proof. destruct d as [[[ch ptr] v] cp0]. ss. des_ifs. Qed. + + Lemma code_mem_delta_correct + (ge: genv) + f k e le m m' + d snext + (WFE: wf_env ge e) + (APPD: mem_delta_apply_wf ge (comp_of f) d (Some m) = Some m') + : + (star step1 ge (State f (code_mem_delta ge (comp_of f) d snext) k e le m) + E0 (State f snext k e le m')). + Proof. + revert m m' snext APPD. induction d; intros. + { unfold mem_delta_apply_wf in APPD. ss. inv APPD. unfold code_mem_delta. ss. econs 1. } + rewrite mem_delta_apply_wf_cons in APPD. rewrite code_mem_delta_cons. + des_ifs. + - exploit mem_delta_apply_wf_some; eauto. intros (mi & APPD0). rewrite APPD0 in APPD. + destruct a; ss. econs 2. + { eapply step_seq. } + econs 2. + { eapply code_mem_delta_storev_correct; eauto. } + take_step. eapply IHd; eauto. eauto. auto. + - destruct a; ss. + rewrite wf_mem_delta_storev_false_is_skip; auto. + all: take_step; take_step; eapply IHd; eauto. + Qed. + + Lemma code_bundle_trace_spec + (ge: genv) cp cnt tr + f e le m k + : + star step1 ge + (State f (code_bundle_trace ge cp cnt tr) k e le m) + E0 + (State f (switch_bundle_events ge cnt cp tr) + (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge cnt cp tr)) Sskip k) + e le m). + Proof. + econs 2. + { unfold code_bundle_trace, Swhile. eapply step_loop. } + econs 2. + { eapply step_seq. } + econs 2. + { eapply step_ifthenelse. simpl_expr. ss. } + rewrite Int.eq_false; ss. econs 2. + { eapply step_skip_seq. } + econs 1. all: eauto. + Qed. + +End CODEPROOFS. + + +Section GENV. + + Definition symbs_public (ge1 ge2: Senv.t) := (forall id : ident, Senv.public_symbol ge2 id = Senv.public_symbol ge1 id). + Definition symbs_find (ge1 ge2: Senv.t) := forall id b, Senv.find_symbol ge1 id = Some b -> Senv.find_symbol ge2 id = Some b. + Definition symbs_volatile (ge1 ge2: Senv.t) := forall b, Senv.block_is_volatile ge2 b = Senv.block_is_volatile ge1 b. + + Definition match_symbs (ge1 ge2: Senv.t) := symbs_public ge1 ge2 /\ symbs_find ge1 ge2 /\ symbs_volatile ge1 ge2. + + Lemma match_symbs_meminj_public + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + : + meminj_public ge1 = meminj_public ge2. + Proof. + destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3). unfold meminj_public. extensionalities b. des_ifs. + - exfalso. apply Senv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. + apply Senv.find_invert_symbol in x0. rewrite x0 in Heq1. inv Heq1. specialize (MSYMB1 i0). clarify. + - exfalso. apply Senv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. + apply Senv.find_invert_symbol in x0. clarify. + - exfalso. apply Senv.invert_find_symbol in Heq. exploit MSYMB2; eauto. intros. + apply Senv.find_invert_symbol in x0. rewrite x0 in Heq1. inv Heq1. specialize (MSYMB1 i0). clarify. + - exfalso. rewrite MSYMB1 in Heq1. apply Senv.public_symbol_exists in Heq1. des. + exploit MSYMB2; eauto. intros. apply Senv.invert_find_symbol in Heq0. clarify. + apply Senv.find_invert_symbol in Heq1. clarify. + Qed. + + Lemma match_symbs_wf_mem_delta_storev + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp0 d + : + wf_mem_delta_storev_b ge1 cp0 d = wf_mem_delta_storev_b ge2 cp0 d. + Proof. + destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3). + destruct d as [[[ch ptr] v] cp]. ss. des_ifs. + - do 2 f_equal. apply Senv.invert_find_symbol, MSYMB2, Senv.find_invert_symbol in Heq. clarify. + - exfalso. apply Senv.invert_find_symbol, MSYMB2, Senv.find_invert_symbol in Heq. clarify. + - destruct (Senv.public_symbol ge2 i0) eqn:PUB; ss. + exfalso. rewrite MSYMB1 in PUB. apply Senv.public_symbol_exists in PUB. des. + exploit MSYMB2; eauto. intros. apply Senv.invert_find_symbol in Heq0. clarify. + apply Senv.find_invert_symbol in PUB. clarify. + Qed. + + Lemma match_symbs_wf_mem_delta_kind + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp + : + wf_mem_delta_kind_b ge1 cp = wf_mem_delta_kind_b ge2 cp. + Proof. unfold wf_mem_delta_kind_b. extensionalities d. des_ifs. apply match_symbs_wf_mem_delta_storev; auto. Qed. + + Lemma match_symbs_get_wf_mem_delta + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp d + : + get_wf_mem_delta ge1 cp d = get_wf_mem_delta ge2 cp d. + Proof. unfold get_wf_mem_delta. erewrite match_symbs_wf_mem_delta_kind; eauto. Qed. + + Lemma match_symbs_mem_delta_apply_wf + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp d m + : + mem_delta_apply_wf ge1 cp d m = mem_delta_apply_wf ge2 cp d m. + Proof. unfold mem_delta_apply_wf. erewrite match_symbs_get_wf_mem_delta; eauto. Qed. + + Lemma match_symbs_code_mem_delta_kind + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp + : + code_mem_delta_kind ge1 cp = code_mem_delta_kind ge2 cp. + Proof. + extensionalities k. unfold code_mem_delta_kind. des_ifs. + destruct d as [[[ch ptr] v] cp0]. ss. destruct ptr; ss. + destruct MSYMB as (MSYMB1 & MSYMB2 & MSYMB3). + destruct (Senv.invert_symbol ge1 b) eqn:INV1. + { exploit Senv.invert_find_symbol; eauto. intros FIND1. + exploit MSYMB2; eauto. intros FIND2. exploit Senv.find_invert_symbol; eauto. intros INV2. + rewrite INV2. destruct (chunk_to_type ch) eqn:CHTY; auto. + des_ifs. + - apply andb_prop in Heq0, Heq2. des. apply andb_prop in Heq0, Heq2. des. + assert (chunk_val_to_expr ge2 ch v = chunk_val_to_expr ge1 ch v). + { unfold chunk_val_to_expr. rewrite CHTY. clear - Heq6. + unfold wf_chunk_val_b in Heq6. des_ifs. + } + rewrite Heq, Heq1 in H. clarify. + - exfalso. apply andb_prop in Heq0. des. apply andb_prop in Heq0. des. + clarify. rewrite ! andb_true_r in Heq2. rewrite MSYMB1 in Heq2. clarify. + - exfalso. apply andb_prop in Heq0. des. apply andb_prop in Heq0. des. + apply (wf_chunk_val_chunk_val_to_expr (ge2)) in Heq3; eauto. des; clarify. + - exfalso. apply andb_prop in Heq2. des. apply andb_prop in Heq2. des. + clarify. rewrite ! andb_true_r in Heq0. rewrite MSYMB1 in Heq2; clarify. + - exfalso. apply andb_prop in Heq1. des. apply andb_prop in Heq1. des. + apply (wf_chunk_val_chunk_val_to_expr (ge1)) in Heq3; eauto. des; clarify. + } + { des_ifs. + exfalso. apply andb_prop in Heq2. des. apply andb_prop in Heq2. des. + rewrite MSYMB1 in Heq2. eapply Senv.public_symbol_exists in Heq2. des. + exploit MSYMB2. eapply Heq2. intros FIND4. eapply Senv.invert_find_symbol in Heq. clarify. + exploit Senv.find_invert_symbol. apply Heq2. intros INV3. clarify. + } + Qed. + + Lemma match_symbs_code_mem_delta + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp d s + : + code_mem_delta ge1 cp d s = code_mem_delta ge2 cp d s. + Proof. unfold code_mem_delta. erewrite match_symbs_code_mem_delta_kind; eauto. Qed. + + Lemma match_symbs_code_bundle_call + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp tr id evargs sg d + : + code_bundle_call ge1 cp tr id evargs sg d = code_bundle_call ge2 cp tr id evargs sg d. + Proof. unfold code_bundle_call. erewrite match_symbs_code_mem_delta; eauto. Qed. + + Lemma match_symbs_code_bundle_return + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp tr evr d + : + code_bundle_return ge1 cp tr evr d = code_bundle_return ge2 cp tr evr d. + Proof. unfold code_bundle_return. erewrite match_symbs_code_mem_delta; eauto. Qed. + + Lemma match_symbs_code_bundle_builtin + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp tr ef evargs d + : + code_bundle_builtin ge1 cp tr ef evargs d = code_bundle_builtin ge2 cp tr ef evargs d. + Proof. unfold code_bundle_builtin. erewrite match_symbs_code_mem_delta; eauto. Qed. + + Lemma match_symbs_code_bundle_events + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp + : + code_bundle_event ge1 cp = code_bundle_event ge2 cp. + Proof. + extensionalities be. unfold code_bundle_event. des_ifs. + eapply match_symbs_code_bundle_call; auto. eapply match_symbs_code_bundle_return; auto. eapply match_symbs_code_bundle_builtin; auto. + Qed. + + Lemma match_symbs_switch_bundle_events + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp cnt tr + : + switch_bundle_events ge1 cnt cp tr = switch_bundle_events ge2 cnt cp tr. + Proof. unfold switch_bundle_events. erewrite match_symbs_code_bundle_events; eauto. Qed. + + Lemma match_symbs_code_bundle_trace + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + cp cnt tr + : + code_bundle_trace ge1 cp cnt tr = code_bundle_trace ge2 cp cnt tr. + Proof. unfold code_bundle_trace. erewrite match_symbs_switch_bundle_events; eauto. Qed. + + + Lemma match_symbs_symbols_inject + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + : + symbols_inject (meminj_public ge1) ge1 ge2. + Proof. + destruct MSYMB as (MS0 & MS1 & MS2). unfold symbols_inject. splits; auto. + - i. unfold meminj_public in H. des_ifs. split; auto. + - i. exists b1. split; auto. unfold meminj_public. apply Senv.find_invert_symbol in H0. + rewrite H0. rewrite H. auto. + - i. unfold meminj_public in H. des_ifs. + Qed. + +End GENV. + + +Section PROOF. + + Lemma filter_filter + A (l: list A) (p q: A -> bool) + : + filter q (filter p l) = filter (fun a => (p a) && (q a)) l. + Proof. + induction l; ss. des_ifs; ss; clarify. + f_equal. auto. + Qed. + + Lemma get_wf_mem_delta_idem + ge cp d + : + get_wf_mem_delta ge cp (get_wf_mem_delta ge cp d) = get_wf_mem_delta ge cp d. + Proof. unfold get_wf_mem_delta. rewrite filter_filter. f_equal. extensionalities k. apply andb_diag. Qed. + + Lemma mem_delta_apply_wf_get_wf_mem_delta + ge cp d m + : + mem_delta_apply_wf ge cp d m = mem_delta_apply_wf ge cp (get_wf_mem_delta ge cp d) m. + Proof. unfold mem_delta_apply_wf. rewrite get_wf_mem_delta_idem. auto. Qed. + + Lemma wf_mem_delta_kind_is_wf + ge cp k + (WF: wf_mem_delta_kind_b ge cp k) + : + mem_delta_kind_inj_wf cp (meminj_public ge) k. + Proof. unfold wf_mem_delta_kind_b in WF. des_ifs. unfold wf_mem_delta_storev_b in WF. ss. des_ifs. apply Pos.eqb_eq in WF. auto. Qed. + + Lemma get_wf_mem_delta_is_wf + cp ge d + : + mem_delta_inj_wf cp (meminj_public ge) (get_wf_mem_delta ge cp d). + Proof. induction d; ss. des_ifs. econs; auto. apply wf_mem_delta_kind_is_wf; auto. Qed. + + Lemma mem_delta_apply_establish_inject2 + (ge: Senv.t) k m0 m0' + (INJ: Mem.inject k m0 m0') + (INCR: inject_incr (meminj_public ge) k) + (NALLOC: meminj_not_alloc (meminj_public ge) m0) + d cp m1 + (APPD: mem_delta_apply_wf ge cp d (Some m0) = Some m1) + (FO: public_first_order ge m1) + : + exists m1', mem_delta_apply_wf ge cp d (Some m0') = Some m1' /\ Mem.inject (meminj_public ge) m1 m1'. + Proof. + unfold mem_delta_apply_wf in APPD. rewrite mem_delta_apply_wf_get_wf_mem_delta. eapply mem_delta_apply_establish_inject; eauto. + apply get_wf_mem_delta_is_wf. + unfold public_first_order in FO. ii. unfold meminj_public in H. des_ifs. apply Senv.invert_find_symbol in Heq. + eapply FO; eauto. + Qed. + + Lemma mem_delta_apply_establish_inject_preprocess_gen + (ge: Senv.t) (k: meminj) m0 m0' + (INJ: Mem.inject k m0 m0') + pch pb pofs pv pcp m0'' + (PRE: Mem.store pch m0' pb pofs pv pcp = Some m0'') + (PREB: forall b ofs, (meminj_public ge) b <> Some (pb, ofs)) + (INCR: inject_incr (meminj_public ge) k) + (NALLOC: meminj_not_alloc (meminj_public ge) m0) + d cp m1 + (APPD: mem_delta_apply_wf ge cp d (Some m0) = Some m1) + : + exists m1', mem_delta_apply_wf ge cp d (Some m0'') = Some m1' /\ + (meminj_first_order (meminj_public ge) m1 -> Mem.inject (meminj_public ge) m1 m1'). + Proof. + unfold mem_delta_apply_wf in APPD. rewrite mem_delta_apply_wf_get_wf_mem_delta. + eapply mem_delta_apply_establish_inject_preprocess_gen; eauto. + apply get_wf_mem_delta_is_wf. + Qed. + + Lemma mem_delta_apply_establish_inject_preprocess2 + (ge: Senv.t) (k: meminj) m0 m0' + (INJ: Mem.inject k m0 m0') + pch pb pofs pv pcp m0'' + (PRE: Mem.store pch m0' pb pofs pv pcp = Some m0'') + (PREB: forall b ofs, (meminj_public ge) b <> Some (pb, ofs)) + (INCR: inject_incr (meminj_public ge) k) + (NALLOC: meminj_not_alloc (meminj_public ge) m0) + d cp m1 + (APPD: mem_delta_apply_wf ge cp d (Some m0) = Some m1) + (FO: public_first_order ge m1) + : + exists m1', mem_delta_apply_wf ge cp d (Some m0'') = Some m1' /\ Mem.inject (meminj_public ge) m1 m1'. + Proof. + hexploit mem_delta_apply_establish_inject_preprocess_gen; eauto. i. des. + esplits; eauto. apply H0. ii. unfold meminj_public in H1. des_ifs. + eapply FO; eauto. apply Senv.invert_find_symbol; auto. + Qed. + +End PROOF. + + + +Section DEFINITIONS. + + Definition meminj_same_block (j : meminj) := + forall b1 b2 del, j b1 = Some (b2, del) -> b1 = b2. + + Definition not_global_blks (ge: Senv.t) (ebs: list block) := + Forall (fun b => Senv.invert_symbol ge b = None) ebs. + + Definition blocks_of_env2 ge e : list block := (map (fun x => fst (fst x)) (blocks_of_env ge e)). + + Definition not_inj_blks (j: meminj) (ebs: list block) := + Forall (fun b => j b = None) ebs. + + Lemma not_global_is_not_inj_bloks + ge l + (NGB: not_global_blks ge l) + : + not_inj_blks (meminj_public ge) l. + Proof. induction NGB. ss. econs; eauto. unfold meminj_public. des_ifs. Qed. + + Definition eq_policy (ge1: Asm.genv) (ge2: genv) := + Genv.genv_policy ge1 = Genv.genv_policy ge2. + +End DEFINITIONS. + + + +Section PROOF. + + (* Properties *) + Lemma eventval_match_transl + (ge: Senv.t) + ev ty v + (EM: eventval_match ge ev ty v) + : + eventval_match ge ev (typ_of_type (typ_to_type ty)) (eventval_to_val ge ev). + Proof. + inversion EM; subst; simpl; try constructor. + setoid_rewrite H0. unfold Tptr in *. destruct Archi.ptr64; auto. + Qed. + + Lemma eventval_match_eventval_to_val + (ge: Senv.t) + ev ty v + (EM: eventval_match ge ev ty v) + : + eventval_to_val ge ev = v. + Proof. inversion EM; subst; simpl; auto. setoid_rewrite H0. auto. Qed. + + Lemma eventval_list_match_transl + (ge: Senv.t) + evs tys vs + (EM: eventval_list_match ge evs tys vs) + : + eventval_list_match ge evs (typlist_of_typelist (list_typ_to_typelist tys)) (list_eventval_to_list_val ge evs). + Proof. induction EM; simpl. constructor. constructor; auto. eapply eventval_match_transl; eauto. Qed. + + Lemma eventval_list_match_transl_val + (ge: Senv.t) + evs tys vs + (EM: eventval_list_match ge evs tys vs) + : + eventval_list_match ge evs tys (list_eventval_to_list_val ge evs). + Proof. induction EM; simpl. constructor. constructor; auto. erewrite eventval_match_eventval_to_val; eauto. Qed. + + Lemma typ_type_typ + (ge: Senv.t) + ev ty v + (EM: eventval_match ge ev ty v) + : + typ_of_type (typ_to_type ty) = ty. + Proof. inversion EM; simpl; auto. subst. unfold Tptr. destruct Archi.ptr64; simpl; auto. Qed. + + Lemma eventval_to_expr_val_eval + (ge: genv) en cp temp m ev ty v + (WFENV: wf_env ge en) + (EM: eventval_match ge ev ty v) + (* (WFGE: wf_eventval_ge ge ev) *) + : + eval_expr ge en cp temp m (eventval_to_expr ev) (eventval_to_val ge ev). + Proof. destruct ev; simpl in *; try constructor. inv EM. setoid_rewrite H4. eapply ptr_of_id_ofs_eval; auto. Qed. + + Lemma sem_cast_eventval_match + (ge: Senv.t) v ty vv m + (EM: eventval_match ge v (typ_of_type (typ_to_type ty)) vv) + : + Cop.sem_cast vv (typeof (eventval_to_expr v)) (typ_to_type ty) m = Some vv. + Proof. + destruct ty; simpl in *; inversion EM; subst; simpl in *; simpl_expr. + all: try rewrite ptr_of_id_ofs_typeof; simpl. + all: try (cbn; auto). + all: unfold Tptr in *; destruct Archi.ptr64 eqn:ARCH; try congruence. + { unfold Cop.sem_cast. simpl. rewrite ARCH. simpl. rewrite pred_dec_true; auto. } + { unfold Cop.sem_cast. simpl. rewrite ARCH. auto. } + { unfold Cop.sem_cast. simpl. rewrite ARCH. simpl. rewrite pred_dec_true; auto. } + { unfold Cop.sem_cast. simpl. rewrite ARCH. auto. } + Qed. + + Lemma list_eventval_to_expr_val_eval + (ge: genv) en cp temp m evs tys + (* (WFENV: Forall (wf_eventval_env en) evs) *) + (WFENV: wf_env ge en) + (EMS: eventval_list_match ge evs (typlist_of_typelist (list_typ_to_typelist tys)) (list_eventval_to_list_val ge evs)) + : + eval_exprlist ge en cp temp m (list_eventval_to_list_expr evs) (list_typ_to_typelist tys) (list_eventval_to_list_val ge evs). + Proof. + revert en cp temp m WFENV. + match goal with | [H: eventval_list_match _ _ ?t ?v |- _] => remember t as tys2; remember v as vs2 end. + revert tys Heqtys2 Heqvs2. induction EMS; intros; subst; simpl in *. + { destruct tys; simpl in *. constructor. congruence. } + inversion Heqvs2; clear Heqvs2; subst; simpl in *. + destruct tys; simpl in Heqtys2. congruence with Heqtys2. + inversion Heqtys2; clear Heqtys2; subst; simpl in *. + econstructor; eauto. eapply eventval_to_expr_val_eval; eauto. + (* eapply eventval_match_wf_eventval_ge; eauto. *) + eapply sem_cast_eventval_match; eauto. + Qed. + + Lemma eventval_match_eventval_to_type + (ge: Senv.t) + ev ty v + (EM: eventval_match ge ev ty v) + : + eventval_match ge ev (typ_of_type (eventval_to_type ev)) v. + Proof. inversion EM; subst; simpl; auto. Qed. + + Lemma list_eventval_match_eventval_to_type + (ge: Senv.t) + evs tys vs + (ESM: eventval_list_match ge evs tys vs) + : + eventval_list_match ge evs (typlist_of_typelist (list_eventval_to_typelist evs)) vs. + Proof. induction ESM; simpl. constructor. constructor; auto. eapply eventval_match_eventval_to_type; eauto. Qed. + + Lemma val_load_result_idem + ch v + : + Val.load_result ch (Val.load_result ch v) = Val.load_result ch v. + Proof. + destruct ch, v; simpl; auto. + 5,6,7: destruct Archi.ptr64; simpl; auto. + 1,3: rewrite Int.sign_ext_idem; auto. + 3,4: rewrite Int.zero_ext_idem; auto. + all: lia. + Qed. + + Lemma val_load_result_aux + F V (ge: Genv.t F V) + ev ch v + (EM: eventval_match ge ev (type_of_chunk ch) (Val.load_result ch v)) + : + eventval_match ge ev (type_of_chunk ch) (Val.load_result ch (eventval_to_val ge ev)). + Proof. + inversion EM; subst; simpl in *; auto. + 1,2,3,4: rewrite H1, H2; rewrite val_load_result_idem; auto. + rewrite H3, H. rewrite H0. rewrite val_load_result_idem. auto. + Qed. + + Lemma eventval_match_proj_rettype + (ge: Senv.t) + ev ty v + (EM: eventval_match ge ev ty v) + : + eventval_match ge ev (proj_rettype (rettype_of_type (typ_to_type ty))) v. + Proof. + inversion EM; subst; simpl; try constructor. + unfold Tptr in *. destruct Archi.ptr64; simpl; auto. + Qed. + + (* Lemma sem_cast_eventval *) + (* (ge: cgenv) v m *) + (* (WFEV: wf_eventval_ge ge v) *) + (* : *) + (* Cop.sem_cast (eventval_to_val ge v) (typeof (eventval_to_expr v)) (eventval_to_type v) m = Some (eventval_to_val ge v). *) + (* Proof. rewrite typeof_eventval_to_expr_type. destruct v; simpl in *; simpl_expr. destruct WFEV. rewrite H. simpl_expr. Qed. *) + + (* Lemma list_eventval_to_expr_val_eval2 *) + (* (ge: genv) en cp temp m evs *) + (* (WFENV: Forall (wf_eventval_env en) evs) *) + (* (WFGE: Forall (wf_eventval_ge ge) evs) *) + (* : *) + (* eval_exprlist ge en cp temp m (list_eventval_to_list_expr evs) (list_eventval_to_typelist evs) (list_eventval_to_list_val ge evs). *) + (* Proof. *) + (* move evs at top. revert ge en cp temp m WFENV WFGE. induction evs; intros; simpl in *. *) + (* constructor. *) + (* inversion WFENV; clear WFENV; subst. inversion WFGE; clear WFGE; subst. *) + (* econstructor; eauto. eapply eventval_to_expr_val_eval; eauto. *) + (* apply sem_cast_eventval; auto. *) + (* Qed. *) + + Lemma eventval_match_sem_cast + (* F V (ge: Genv.t F V) *) + (ge: genv) + m ev ty v + (EM: eventval_match ge ev ty v) + : + (* Cop.sem_cast (eventval_to_val ge ev) (typeof (eventval_to_expr ev)) (typ_to_type ty) m = Some (eventval_to_val ge ev). *) + Cop.sem_cast v (typeof (eventval_to_expr ev)) (typ_to_type ty) m = Some v. + Proof. + inversion EM; subst; simpl; try constructor. all: simpl_expr. + rewrite ptr_of_id_ofs_typeof. unfold Tptr. unfold Cop.sem_cast. destruct Archi.ptr64 eqn:ARCH; simpl. + - rewrite ARCH; auto. + - rewrite ARCH; auto. + Qed. + + (* Lemma list_eventval_to_expr_val_eval_typs *) + (* (ge: genv) en cp temp m evs tys vs *) + (* (WFENV: Forall (wf_eventval_env en) evs) *) + (* (EMS: eventval_list_match ge evs tys vs) *) + (* : *) + (* eval_exprlist ge en cp temp m (list_eventval_to_list_expr evs) (list_typ_to_typelist tys) vs. *) + (* Proof. *) + (* revert en cp temp m WFENV. *) + (* induction EMS; intros; subst; simpl in *. constructor. *) + (* inversion WFENV; clear WFENV; subst. *) + (* econstructor; eauto. 2: eapply eventval_match_sem_cast; eauto. *) + (* exploit eventval_match_eventval_to_val. eauto. intros. rewrite <- H0. eapply eventval_to_expr_val_eval; auto. *) + (* eapply eventval_match_wf_eventval_ge; eauto. *) + (* Qed. *) + + Lemma sem_cast_ptr + b ofs m + : + Cop.sem_cast (Vptr b ofs) (Tpointer Tvoid noattr) (typ_to_type Tptr) m = Some (Vptr b ofs). + Proof. + unfold Tptr. destruct Archi.ptr64 eqn:ARCH; unfold Cop.sem_cast; simpl; rewrite ARCH; auto. + Qed. + + Lemma sem_cast_proj_rettype + (ge: genv) evres rty res m + (EVM: eventval_match ge evres (proj_rettype rty) res) + : + Cop.sem_cast (eventval_to_val ge evres) + (typeof (eventval_to_expr evres)) + (rettype_to_type rty) m + = Some (eventval_to_val ge evres). + Proof. + destruct rty; simpl in *. + { eapply eventval_match_sem_cast. eauto. erewrite eventval_match_eventval_to_val; eauto. } + { inv EVM; simpl; simpl_expr. + setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. + unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. + unfold Cop.sem_cast. simpl. rewrite ARCH. auto. + } + { inv EVM; simpl; simpl_expr. + setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. + unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. + unfold Cop.sem_cast. simpl. rewrite ARCH. auto. + } + { inv EVM; simpl; simpl_expr. + setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. + unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. + unfold Cop.sem_cast. simpl. rewrite ARCH. auto. + } + { inv EVM; simpl; simpl_expr. + setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. + unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. + unfold Cop.sem_cast. simpl. rewrite ARCH. auto. + } + { inv EVM; simpl; simpl_expr. + setoid_rewrite H2. rewrite ptr_of_id_ofs_typeof. + unfold Tptr in *. destruct Archi.ptr64 eqn:ARCH. congruence. + unfold Cop.sem_cast. simpl. rewrite ARCH. auto. + } + Qed. + + Lemma type_of_params_eq + params ts + (PARSIGS : list_typ_to_list_type ts = map snd params) + : + type_of_params params = list_typ_to_typelist ts. + Proof. + revert params PARSIGS. induction ts; ii; ss. + { destruct params; ss. } + destruct params; ss. destruct p; ss. clarify. f_equal. auto. + Qed. + + Lemma match_senv_eventval_match + (ge0 ge1: Senv.t) + (MS: match_symbs ge0 ge1) + ev ty v + (EM: eventval_match ge0 ev ty v) + : + eventval_match ge1 ev ty v. + Proof. destruct MS as (MS0 & MS1 & MS2). inv EM; try econs; auto. rewrite MS0. auto. Qed. + + Lemma match_senv_eventval_list_match + (ge0 ge1: Senv.t) + (MS: match_symbs ge0 ge1) + evs tys vs + (EM: eventval_list_match ge0 evs tys vs) + : + eventval_list_match ge1 evs tys vs. + Proof. induction EM; ss. econs; auto. econs; auto. eapply match_senv_eventval_match; eauto. Qed. + + Lemma unbundle_trace_app + tr1 tr2 + : + unbundle_trace (tr1 ++ tr2) = (unbundle_trace tr1) ++ (unbundle_trace tr2). + Proof. induction tr1; ss. rewrite <- app_assoc. f_equal. auto. Qed. + + Lemma allowed_call_gen_function + cp (ge_i: Asm.genv) (ge_c: genv) next cnt params tr f_i f_c + (GE: symbs_find ge_i ge_c) + (GEPOL: eq_policy ge_i ge_c) + (GEN: f_c = gen_function ge_i cnt params tr f_i) + (ALLOW : Genv.allowed_call ge_i cp (Vptr next Ptrofs.zero)) + (FINDF : Genv.find_funct ge_i (Vptr next Ptrofs.zero) = Some (AST.Internal f_i)) + (FINDF_C : Genv.find_funct ge_c (Vptr next Ptrofs.zero) = Some (Internal f_c)) + : + Genv.allowed_call ge_c cp (Vptr next Ptrofs.zero). + Proof. + unfold Genv.allowed_call in *. des; [left | right]. + - subst. unfold Genv.find_comp. rewrite FINDF, FINDF_C. ss. + - subst. unfold Genv.allowed_cross_call in *. des. + unfold eq_policy in GEPOL. rewrite GEPOL in ALLOW2, ALLOW3. + specialize (ALLOW0 _ FINDF). exists i, cp'. splits; auto. + { apply Genv.invert_find_symbol in ALLOW. apply Genv.find_invert_symbol. + apply GE. auto. + } + { i. rewrite FINDF_C in H. clarify. } + { unfold Genv.find_comp in *. rewrite FINDF in ALLOW1. rewrite FINDF_C. + rewrite <- ALLOW1. ss. + } + Qed. + + Lemma allowed_call_gen_function_external + cp (ge_i: Asm.genv) (ge_c: genv) next ef + (GE: symbs_find ge_i ge_c) + (GEPOL: eq_policy ge_i ge_c) + (ALLOW : Genv.allowed_call ge_i cp (Vptr next Ptrofs.zero)) + (FINDF : Genv.find_funct ge_i (Vptr next Ptrofs.zero) = Some (AST.External ef)) + (FINDF_C : Genv.find_funct ge_c (Vptr next Ptrofs.zero) = + Some (External ef + (list_typ_to_typelist (sig_args (ef_sig ef))) + (rettype_to_type (sig_res (ef_sig ef))) + (sig_cc (ef_sig ef)))) + : + Genv.allowed_call ge_c cp (Vptr next Ptrofs.zero). + Proof. + unfold Genv.allowed_call in *. des; [left | right]. + - subst. unfold Genv.find_comp. rewrite FINDF, FINDF_C. ss. + - unfold Genv.allowed_cross_call in *. des. + unfold eq_policy in GEPOL. rewrite GEPOL in ALLOW2, ALLOW3. + specialize (ALLOW0 _ FINDF). exists i, cp'. splits; auto. + { apply Genv.invert_find_symbol in ALLOW. apply Genv.find_invert_symbol. + apply GE. auto. + } + { i. rewrite FINDF_C in H. clarify. } + { unfold Genv.find_comp in *. rewrite FINDF in ALLOW1. rewrite FINDF_C. + rewrite <- ALLOW1. ss. + } + Qed. + + Lemma eventval_list_match_list_eventval_to_list_val + (ge: Senv.t) evargs tys vargs + (EVMS: eventval_list_match ge evargs tys vargs) + : + list_eventval_to_list_val ge evargs = vargs. + Proof. + induction EVMS; ss. f_equal; auto. + eapply eventval_match_eventval_to_val. eauto. + Qed. + + Lemma match_symbs_eventval_match + ge0 ge1 ev ty v + (MS: match_symbs ge0 ge1) + (EVM: eventval_match ge0 ev ty v) + : + eventval_match ge1 ev ty v. + Proof. + destruct MS as (MS0 & MS1 & MS2). inv EVM; econs; auto. rewrite MS0; auto. + Qed. + + Lemma match_symbs_eventval_list_match + ge0 ge1 ev ty v + (MS: match_symbs ge0 ge1) + (EVM: eventval_list_match ge0 ev ty v) + : + eventval_list_match ge1 ev ty v. + Proof. + induction EVM. econs. econs; auto. eapply match_symbs_eventval_match; eauto. + Qed. + + Lemma alloc_variables_exists + ge cp e m l + : + exists e' m', alloc_variables ge cp e m l e' m'. + Proof. + revert ge cp e m. induction l; ii. + { do 2 eexists. econs 1. } + destruct a as (id & ty). + destruct (Mem.alloc m cp 0 (sizeof ge ty)) as (m0 & b0) eqn:ALLOC. + specialize (IHl ge cp (PTree.set id (b0, ty) e) m0). des. + do 2 eexists. econs 2. eapply ALLOC. eapply IHl. + Qed. + + Lemma access_mode_typ_to_type + s + : + exists ch, access_mode (typ_to_type s) = By_value ch. + Proof. destruct s; ss; eauto. Qed. + + Lemma bind_parameters_exists + (ge: genv) cp (e: env) m params vargs + (INENV: Forall (fun '(id, ty) => + exists b, (e ! id = Some (b, ty)) /\ + (forall ch, access_mode ty = By_value ch -> + Mem.valid_access m ch b 0 Writable (Some cp))) + params) + sg + (PARSIGS: list_typ_to_list_type sg = map snd params) + evargs + (EMS: eventval_list_match ge evargs sg vargs) + : + exists m', bind_parameters ge cp e m params vargs m'. + Proof. + revert e m vargs INENV sg PARSIGS evargs EMS. induction params; ii. + { ss. inv EMS; ss. eexists. econs. } + destruct a as (id & ty). inv INENV. des. ss. + destruct sg; ss. rename t into s. clarify. inv EMS. + destruct (access_mode_typ_to_type s) as (ch & ACCM). + specialize (H0 _ ACCM). hexploit Mem.valid_access_store. apply H0. instantiate (1:=v1). + intros (m0 & STORE). + assert + (FA: Forall + (fun '(id, ty) => + exists b : block, + e ! id = Some (b, ty) /\ + (forall ch : memory_chunk, access_mode ty = By_value ch -> + Mem.valid_access m0 ch b 0 Writable (Some cp))) params). + { clear - H2 STORE. move H2 before cp. revert_until H2. induction H2; ii; ss. + econs; eauto. des_ifs. des. esplits; eauto. i. eapply Mem.store_valid_access_1; eauto. + } + hexploit IHparams. apply FA. 1,2: eauto. intros. des. exists m'. + econs; eauto. econs; eauto. + Qed. + + Lemma alloc_variables_wf_id + ge cp e m params e' m' + (EA: alloc_variables ge cp e m params e' m') + (WF: list_norepet (var_names params)) + : + forall id bt, (~ In id (var_names params)) -> (e ! id = Some bt) -> (e' ! id = Some bt). + Proof. + revert WF. induction EA; ii; ss. + apply Classical_Prop.not_or_and in H0. des. inv WF. + apply IHEA; auto. rewrite PTree.gso; auto. + Qed. + + Lemma alloc_variables_valid_access + ge cp e m params e' m' + (EA: alloc_variables ge cp e m params e' m') + : + forall b' ch' ofs' p' cp', Mem.valid_access m ch' b' ofs' p' cp' -> + Mem.valid_access m' ch' b' ofs' p' cp'. + Proof. + i. assert (WF: (b' < Mem.nextblock m)%positive). + { unfold Mem.valid_access in H. des. destruct (Unusedglob.IS.MSet.Raw.MX.lt_dec b' (Mem.nextblock m)); auto. + exfalso. unfold Mem.range_perm in H. specialize (H ofs'). + eapply (Mem.nextblock_noaccess _ _ ofs' Cur) in n. + exploit H. + { pose proof (size_chunk_pos ch'). lia. } + i. unfold Mem.perm in x0. rewrite n in x0. ss. + } + revert_until EA. induction EA; ii; ss. + apply IHEA. + { eapply Mem.valid_access_alloc_other; eauto. } + { erewrite Mem.nextblock_alloc; eauto. lia. } + Qed. + + Lemma alloc_variables_forall + ge cp e m params e' m' + (EA: alloc_variables ge cp e m params e' m') + (WF: list_norepet (var_names params)) + : + Forall (fun '(id, ty) => + exists b, (e' ! id = Some (b, ty)) /\ + (forall ch, access_mode ty = By_value ch -> + Mem.valid_access m' ch b 0 Writable (Some cp))) params. + Proof. + revert WF. induction EA; ii; ss. + inv WF. econs; eauto. + hexploit alloc_variables_wf_id. apply EA. auto. apply H2. apply PTree.gss. + i. esplits; eauto. + i. eapply alloc_variables_valid_access. apply EA. + apply Mem.valid_access_freeable_any. eapply Mem.valid_access_alloc_same; eauto. lia. + { ss. clear - H1. destruct ty; ss; clarify. des_ifs; clarify; ss. des_ifs; clarify; ss. unfold Mptr. des_ifs. } + exists 0. ss. + Qed. + + Lemma assign_loc_valid_access + ge cp ty m b ofs bit v m' + (AL: assign_loc ge cp ty m b ofs bit v m') + ch' b' ofs' perm' cp' + (VA: Mem.valid_access m ch' b' ofs' perm' (Some cp')) + : + Mem.valid_access m' ch' b' ofs' perm' (Some cp'). + Proof. + inv AL. + - eapply Mem.store_valid_access_1; eauto. + - eapply Mem.storebytes_valid_access_1; eauto. + - inv H. eapply Mem.store_valid_access_1; eauto. + Qed. + + Lemma bind_parameters_valid_access + (ge: genv) cp (e: env) m params vargs m' + (BIND: bind_parameters ge cp e m params vargs m') + ch b ofs perm cp' + (VA: Mem.valid_access m ch b ofs perm (Some cp')) + : + Mem.valid_access m' ch b ofs perm (Some cp'). + Proof. + revert_until BIND. induction BIND; ii; ss. + apply IHBIND. eapply assign_loc_valid_access; eauto. + Qed. + + Lemma mem_delta_apply_wf_valid_access + ge cp d m m' + (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') + ch b ofs perm cp' + (VA: Mem.valid_access m ch b ofs perm cp') + : + Mem.valid_access m' ch b ofs perm cp'. + Proof. + move d before ge. revert_until d. induction d; ii. + { unfold mem_delta_apply_wf in APPD. ss; clarify. } + rewrite mem_delta_apply_wf_cons in APPD. des_ifs. + - destruct a; ss. hexploit mem_delta_apply_wf_some; eauto. + intros (m0 & STOREV). rewrite STOREV in APPD. + eapply IHd. apply APPD. + unfold mem_delta_apply_storev in STOREV. des_ifs. + unfold Mem.storev in STOREV. des_ifs. + eapply Mem.store_valid_access_1; eauto. + - eapply IHd; eauto. + Qed. + + Lemma bind_parameters_mem_load + ge cp e m0 params vargs m1 + (BIND: bind_parameters ge cp e m0 params vargs m1) + : + forall ch b ofs cp', + (forall id b_e ty, (e ! id = Some (b_e, ty) -> b <> b_e)) -> + (Mem.load ch m1 b ofs cp' = Mem.load ch m0 b ofs cp'). + Proof. + induction BIND; ii; ss. + rewrite IHBIND; auto. + inv H0. + - eapply Mem.load_store_other. eapply H3. left. ii. clarify. specialize (H1 _ _ _ H). clarify. + - eapply Mem.load_storebytes_other. eapply H7. left. ii. clarify. specialize (H1 _ _ _ H). clarify. + Qed. + + Lemma alloc_variables_mem_load + ge cp e m params e' m' + (EA: alloc_variables ge cp e m params e' m') + : + forall ch b ofs cp', + (b < Mem.nextblock m)%positive -> + (Mem.load ch m' b ofs cp' = Mem.load ch m b ofs cp'). + Proof. + induction EA; ii; ss. + rewrite IHEA. + { eapply Mem.load_alloc_unchanged; eauto. } + { erewrite Mem.nextblock_alloc; eauto. lia. } + Qed. + + Lemma alloc_variables_old_blocks + ge cp e m params e' m' + (EA: alloc_variables ge cp e m params e' m') + : + forall b, (b < Mem.nextblock m)%positive -> + (forall id b' ty, e ! id = Some (b', ty) -> b <> b') -> + (forall id b' ty, e' ! id = Some (b', ty) -> b <> b'). + Proof. + induction EA; i. + { ii; clarify. specialize (H0 _ _ _ H1). clarify. } + hexploit Mem.alloc_result; eauto. intros; clarify. + eapply IHEA. 3: eapply H2. + { erewrite Mem.nextblock_alloc; eauto. lia. } + { i. destruct (Pos.eq_dec id id1). + - clarify. rewrite PTree.gss in H3. clarify. lia. + - rewrite PTree.gso in H3; auto. eapply H1; eauto. + } + Qed. + + Lemma mem_delta_apply_wf_mem_load + ge cp d m m' + (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') + : + forall id ch b ofs cp', + Senv.invert_symbol ge b = Some id -> + Senv.public_symbol ge id = false -> + (Mem.load ch m' b ofs cp' = Mem.load ch m b ofs cp'). + Proof. + move d before ge. revert_until d. induction d; ii. + { unfold mem_delta_apply_wf in APPD. ss. clarify. } + rewrite mem_delta_apply_wf_cons in APPD. des_ifs. + { destruct a; ss. unfold wf_mem_delta_storev_b in Heq. des_ifs. ss. + hexploit mem_delta_apply_wf_some; eauto. intros (m1 & STORE). rewrite STORE in APPD. + erewrite IHd. 2: eauto. 2: eauto. all: auto. + destruct (Pos.eq_dec b b0). + - clarify. + - erewrite Mem.load_store_other. 2: eauto. all: auto. + } + { eapply IHd; eauto. } + Qed. + + Lemma nat64_int64_add_one + n + (BOUND: Z.of_nat n < Int64.modulus) + : + Int64.add (nat64 n) Int64.one = nat64 (n + 1). + Proof. + unfold nat64. rewrite Nat2Z.inj_add. ss. + assert (N: Z.of_nat n = Int64.unsigned (Int64.repr (Z.of_nat n))). + { symmetry. apply Int64.unsigned_repr. split. apply Zle_0_nat. + unfold Int64.max_unsigned. lia. + } + assert (ONE: 1 = (Int64.unsigned (Int64.repr 1))). + { ss. } + rewrite N at 2. rewrite ONE. rewrite <- Int64.add_unsigned. ss. + Qed. + + Lemma mem_free_list_impl1 + blks m cp m_f + (FREE: Mem.free_list m blks cp = Some m_f) + : + Forall (fun '(b, lo, hi) => (Mem.range_perm m b lo hi Cur Freeable) /\ (Mem.can_access_block m b (Some cp))) blks. + Proof. + Local Opaque Mem.can_access_block. + revert_until blks. induction blks; ii; ss. des_ifs. ss. econs. + 2:{ cut (Forall (fun '(b0, lo, hi) => Mem.range_perm m0 b0 lo hi Cur Freeable /\ Mem.can_access_block m0 b0 (Some cp)) blks); cycle 1. + { eapply IHblks; eauto. } + clear - Heq. intros FA. revert_until blks. induction blks; ii; ss. + destruct a as ((ba & loa) & hia). ss. inv FA. des; clarify. econs. + { + clear IHblks. split. + - unfold Mem.range_perm in *. ii. eapply Mem.perm_free_3. eauto. eauto. + - eapply Mem.free_can_access_block_inj_2; eauto. + } + eapply IHblks; eauto. + } + split. + - eapply Mem.free_range_perm; eauto. + - eapply Mem.free_can_access_block_1; eauto. + Local Transparent Mem.can_access_block. + Qed. + + Lemma mem_free_list_impl2 + blks m cp + (NR: list_norepet (map (fun x => fst (fst x)) blks)) + (FA: Forall (fun '(b, lo, hi) => (Mem.range_perm m b lo hi Cur Freeable) /\ (Mem.can_access_block m b (Some cp))) blks) + : + exists m_f, (Mem.free_list m blks cp = Some m_f). + Proof. + Local Opaque Mem.can_access_block. + revert_until blks. induction blks; ii; ss; eauto. + inv FA. inv NR. des_ifs; des. + 2:{ exfalso. destruct (Mem.range_perm_free _ _ _ _ _ H1 H0) as (m0 & FREE). clarify. } + eapply IHblks; clear IHblks; eauto. ss. clear - H2 H3 Heq. + revert_until blks. induction blks; ii; ss. inv H2. des_ifs; ss. des. econs; eauto. + clear IHblks H4. apply Classical_Prop.not_or_and in H3. des. split. + - unfold Mem.range_perm in *. ii. hexploit Mem.perm_free_inv; eauto. ii. des; clarify. + - eapply Mem.free_can_access_block_inj_1; eauto. + Local Transparent Mem.can_access_block. + Qed. + + Lemma list_map_norepet_rev + A (l: list A) B (f: A -> B) + (NR: list_norepet (map f l)) + : + list_norepet l. + Proof. + revert NR. induction l; ii; ss. econs. inv NR. econs; eauto. + ii. apply H1; clear H1. apply in_map; auto. + Qed. + + Lemma alloc_variables_wunchanged_on + ge cp e m params e' m' + (EA: alloc_variables ge cp e m params e' m') + : + wunchanged_on (fun b _ => Mem.valid_block m b) m m'. + Proof. + induction EA. apply wunchanged_on_refl. + eapply wunchanged_on_implies in IHEA. + { eapply wunchanged_on_trans. 2: eauto. eapply alloc_wunchanged_on. eauto. } + { ii. ss. } + Qed. + + Lemma alloc_variables_exists_free_list + ge cp e m params e' m' + (EA: alloc_variables ge cp e m params e' m') + (ENV1: forall id1 id2 b1 b2 t1 t2, (id1 <> id2) -> (e ! id1 = Some (b1, t1)) -> (e ! id2 = Some (b2, t2)) -> (b1 <> b2)) + (ENV2: forall id b t, (e ! id = Some (b, t)) -> (Mem.valid_block m b)) + m_f0 + (FREE: Mem.free_list m' (blocks_of_env ge e) cp = Some m_f0) + : + exists m_f, Mem.free_list m' (blocks_of_env ge e') cp = Some m_f. + Proof. + revert_until EA. induction EA; ii; ss; eauto. + assert (exists m_f0, Mem.free_list m2 (blocks_of_env ge (PTree.set id (b1, ty) e)) cp = Some m_f0); cycle 1. + { des. eapply IHEA; clear IHEA; eauto. + - i. destruct (Pos.eqb_spec id id1); clarify. + + rewrite PTree.gss in H2. rewrite PTree.gso in H3; auto. clarify. specialize (ENV2 _ _ _ H3). + ii. clarify. apply Mem.fresh_block_alloc in H. clarify. + + destruct (Pos.eqb_spec id id2); clarify. + * rewrite PTree.gso in H2; auto. rewrite PTree.gss in H3; auto. clarify. specialize (ENV2 _ _ _ H2). + ii. clarify. apply Mem.fresh_block_alloc in H. clarify. + * rewrite PTree.gso in H2, H3; auto. hexploit ENV1. 2: eapply H2. 2: eapply H3. all: auto. + - i. destruct (Pos.eqb_spec id id0); clarify. + + rewrite PTree.gss in H1. clarify. eapply Mem.valid_new_block; eauto. + + rewrite PTree.gso in H1; auto. specialize (ENV2 _ _ _ H1). eapply Mem.valid_block_alloc; eauto. + } + clear IHEA. eapply mem_free_list_impl2. + { unfold blocks_of_env. rewrite map_map. apply list_map_norepet. + { eapply list_map_norepet_rev. apply PTree.elements_keys_norepet. } + { i. unfold block_of_binding. des_ifs. ss. apply PTree.elements_complete in H0, H1. + destruct (Pos.eqb_spec id i); clarify. + - rewrite PTree.gss in H0. clarify. destruct (Pos.eqb_spec i i0); clarify. + + rewrite PTree.gss in H1; clarify. + + rewrite PTree.gso in H1; auto. specialize (ENV2 _ _ _ H1). ii; clarify. + apply Mem.fresh_block_alloc in H. clarify. + - rewrite PTree.gso in H0; auto. destruct (Pos.eqb_spec id i0); clarify. + + rewrite PTree.gss in H1. clarify. specialize (ENV2 _ _ _ H0). ii; clarify. + apply Mem.fresh_block_alloc in H. clarify. + + rewrite PTree.gso in H1; auto. eapply ENV1. 2: apply H0. 2: apply H1. ii; clarify. + } + } + { apply mem_free_list_impl1 in FREE. rewrite Forall_forall in *. i. + assert ((x = (b1, 0%Z, sizeof ge ty)) \/ (In x (blocks_of_env ge e))). + { clear - H0. unfold blocks_of_env in *. apply list_in_map_inv in H0. des. + destruct x0 as (xid & xb & xt). apply PTree.elements_complete in H1. clarify. + destruct (Pos.eqb_spec id xid); clarify. + - rewrite PTree.gss in H1. clarify. left; auto. + - rewrite PTree.gso in H1; auto. right. apply in_map. apply PTree.elements_correct. auto. + } + des. + - clarify. split. + + ii. eapply perm_wunchanged_on. eapply alloc_variables_wunchanged_on; eauto. + { ss. eapply Mem.valid_new_block; eauto. } + { eapply Mem.perm_alloc_2; eauto. } + + rewrite <- wunchanged_on_own. 2: eapply alloc_variables_wunchanged_on; eauto. + eapply Mem.owned_new_block; eauto. eapply Mem.valid_new_block; eauto. + - eapply FREE. eauto. + } + Qed. + + Lemma assign_loc_wunchanged_on + ge cp ty m b ofs bit v m' + (AL: assign_loc ge cp ty m b ofs bit v m') + : + wunchanged_on (fun _ _ => True) m m'. + Proof. + inv AL. + - eapply store_wunchanged_on; eauto. + - eapply storebytes_wunchanged_on; eauto. + - inv H. eapply store_wunchanged_on; eauto. + Qed. + + Lemma bind_parameters_wunchanged_on + (ge: genv) cp (e: env) m params vargs m' + (BIND: bind_parameters ge cp e m params vargs m') + : + wunchanged_on (fun _ _ => True) m m'. + Proof. + induction BIND. apply wunchanged_on_refl. eapply wunchanged_on_trans. 2: apply IHBIND. + eapply assign_loc_wunchanged_on; eauto. + Qed. + + Lemma wunchanged_on_exists_free + m m' + (WU: wunchanged_on (fun b _ => Mem.valid_block m b) m m') + b lo hi cp m_f + (FREE: Mem.free m b lo hi cp = Some m_f) + : + exists m_f', Mem.free m' b lo hi cp = Some m_f'. + Proof. + hexploit Mem.free_range_perm; eauto. hexploit Mem.free_can_access_block_1; eauto. i. + hexploit Mem.range_perm_free. + 3:{ intros (m0 & F). eexists; eapply F. } + - unfold Mem.range_perm in *. i. eapply perm_wunchanged_on. 3: eauto. eauto. ss. eapply Mem.perm_valid_block; eauto. + - rewrite <- wunchanged_on_own; eauto. eapply Mem.can_access_block_valid_block. eauto. + Qed. + + Lemma assign_loc_perm + ge cp ty m b ofs bit v m' + (AL: assign_loc ge cp ty m b ofs bit v m') + b' o' C P + (PERM: Mem.perm m b' o' C P) + : + Mem.perm m' b' o' C P. + Proof. + inv AL. + - eapply Mem.perm_store_1; eauto. + - eapply Mem.perm_storebytes_1; eauto. + - inv H. eapply Mem.perm_store_1; eauto. + Qed. + + Lemma assign_loc_own + ge cp ty m b ofs bit v m' + (AL: assign_loc ge cp ty m b ofs bit v m') + b' cp' + (OWN: Mem.can_access_block m b' cp') + : + Mem.can_access_block m' b' cp'. + Proof. + inv AL. + - rewrite <- Mem.store_can_access_block_inj; eauto. + - eapply Mem.storebytes_can_access_block_inj_1; eauto. + - inv H. rewrite <- Mem.store_can_access_block_inj; eauto. + Qed. + + Lemma assign_loc_exists_free + ge cp ty m b ofs bit v m' + (AL: assign_loc ge cp ty m b ofs bit v m') + b' lo hi cp' m_f + (FREE: Mem.free m b' lo hi cp' = Some m_f) + : + exists m_f, Mem.free m' b' lo hi cp' = Some m_f. + Proof. + hexploit Mem.free_range_perm; eauto. hexploit Mem.free_can_access_block_1; eauto. i. + hexploit Mem.range_perm_free. + 3:{ intros (m0 & F). eexists; eapply F. } + - unfold Mem.range_perm in *. i. eapply assign_loc_perm; eauto. + - eapply assign_loc_own; eauto. + Qed. + + Lemma wunchanged_on_free_preserves + m m' + (WU : wunchanged_on (fun (b : block) (_ : Z) => Mem.valid_block m b) m m') + b lo hi cp m1 m1' + (FREE: Mem.free m b lo hi cp = Some m1) + (FREE': Mem.free m' b lo hi cp = Some m1') + : + wunchanged_on (fun (b0 : block) (_ : Z) => Mem.valid_block m1 b0) m1 m1'. + Proof. + inv WU. econs. + - rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE). rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE'). auto. + - i. assert (VB: Mem.valid_block m b0). + { eapply Mem.valid_block_free_2; eauto. } + split; i. + + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE _ _ _ _ H1). rewrite wunchanged_on_perm in H2; auto. + eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. + hexploit Mem.perm_free_2. eapply FREE. split; eauto. i. exfalso. apply H2. eapply H1. + + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE' _ _ _ _ H1). rewrite <- wunchanged_on_perm in H2; auto. + eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. + hexploit Mem.perm_free_2. eapply FREE'. split; eauto. i. exfalso. apply H2. eapply H1. + - i. assert (VB: Mem.valid_block m b0). + { eapply Mem.valid_block_free_2; eauto. } + split; i. + + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. + eapply Mem.free_can_access_block_inj_2; eauto. + + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. + eapply Mem.free_can_access_block_inj_2; eauto. + Qed. + + Lemma wunchanged_on_exists_mem_free_list + m m' + (WU: wunchanged_on (fun b _ => Mem.valid_block m b) m m') + l cp m_f + (FREE: Mem.free_list m l cp = Some m_f) + : + exists m_f', Mem.free_list m' l cp = Some m_f'. + Proof. + move l after m. revert_until l. induction l; ii; ss; eauto. des_ifs. + 2:{ exfalso. hexploit wunchanged_on_exists_free. 2: eapply Heq0. 2: auto. + 2:{ intros. des. rewrite H in Heq; clarify. } + auto. + } + hexploit IHl. 2: eapply FREE. + { instantiate (1:=m0). eapply wunchanged_on_free_preserves; eauto. } + eauto. + Qed. + + Lemma mem_free_list_wunchanged_on + x m l cp m' + (FL: Mem.free_list m l cp = Some m') + (WF: Forall (fun '(b, lo, hi) => (x <= b)%positive) l) + : + wunchanged_on (fun b _ => (b < x)%positive) m m'. + Proof. + move WF before x. revert_until WF. induction WF; i; ss. clarify. apply wunchanged_on_refl. des_ifs. + hexploit IHWF; eauto. i. eapply wunchanged_on_trans. 2: eauto. + eapply free_wunchanged_on; eauto. + i. lia. + Qed. + + Lemma wunchanged_on_free_list_preserves + m m' + (WU: wunchanged_on (fun b _ => Mem.valid_block m b) m m') + l cp m_f m_f' + (FREE: Mem.free_list m l cp = Some m_f) + (FREE': Mem.free_list m' l cp = Some m_f') + : + wunchanged_on (fun b _ => Mem.valid_block m_f b) m_f m_f'. + Proof. + move l after m. revert_until l. induction l; ii; ss. clarify. + des_ifs. eapply IHl. 2,3: eauto. eapply wunchanged_on_free_preserves; eauto. + Qed. + + Lemma mem_delta_apply_wf_wunchanged_on + ge cp d m m' + (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') + P + : + wunchanged_on P m m'. + Proof. + revert_until d. induction d; ii; ss. + { cbn in APPD. clarify. apply wunchanged_on_refl. } + rewrite mem_delta_apply_wf_cons in APPD. des_ifs. + - hexploit mem_delta_apply_wf_some; eauto. intros (m0 & ST). rewrite ST in APPD. + specialize (IHd _ _ APPD). unfold mem_delta_apply_kind in ST. unfold mem_delta_apply_storev in ST. des_ifs. + ss. des_ifs. ss. eapply wunchanged_on_trans. eapply store_wunchanged_on. eapply ST. + eapply wunchanged_on_implies. eapply IHd. ss. + - eauto. + Unshelve. all: exact 0%nat. + Qed. + + Lemma alloc_variables_fresh_blocks + ge cp e m params e' m' + (EA: alloc_variables ge cp e m params e' m') + x + (X: (x <= Mem.nextblock m)%positive) + (FA: Forall (fun '(b0, _, _) => (x <= b0)%positive) (blocks_of_env ge e)) + : + Forall (fun '(b0, _, _) => (x <= b0)%positive) (blocks_of_env ge e'). + Proof. + revert_until EA. induction EA; ii; ss. specialize (IHEA x). + eapply IHEA; clear IHEA. + { erewrite Mem.nextblock_alloc; eauto. lia. } + apply Forall_forall. rewrite Forall_forall in FA. ii. specialize (FA x0). des_ifs. + unfold blocks_of_env in H0. apply list_in_map_inv in H0. des. destruct x0 as (xid & xb & xt). + apply PTree.elements_complete in H1. destruct (Pos.eqb_spec id xid); clarify. + - rewrite PTree.gss in H1. ss. clarify. erewrite Mem.alloc_result. 2: eauto. auto. + - rewrite PTree.gso in H1; auto. apply FA. rewrite H0. unfold blocks_of_env. apply in_map. + apply PTree.elements_correct; auto. + Qed. + + Lemma alloc_variables_one_fresh_block + ge cp e m params e' m' + (EA: alloc_variables ge cp e m params e' m') + (NR: list_norepet (var_names params)) + xid xb xt + (NOT: e ! xid = None) + (GET: e' ! xid = Some (xb, xt)) + : + ~ (Mem.valid_block m xb). + Proof. + revert_until EA. induction EA; i. clarify. + inv NR. destruct (Pos.eqb_spec xid id). + { subst id. hexploit alloc_variables_wf_id. eauto. auto. eauto. apply PTree.gss. + i. rewrite GET in H0. clarify. eapply Mem.fresh_block_alloc; eauto. } + hexploit IHEA. auto. rewrite PTree.gso. eapply NOT. auto. eapply GET. i. + ii. apply H0. unfold Mem.valid_block in *. erewrite Mem.nextblock_alloc; eauto. + etransitivity. eapply H1. apply Plt_succ. + Qed. + + Lemma assign_loc_outside_mem_inject + ge cp ty m b ofs bf v m' + (AL: assign_loc ge cp ty m b ofs bf v m') + k m0 + (INJ: Mem.inject k m0 m) + (NIB: k b = None) + (MS: meminj_same_block k) + : + Mem.inject k m0 m'. + Proof. + inv AL. + - eapply Mem.store_outside_inject; eauto. i. specialize (MS _ _ _ H1). clarify. + - eapply Mem.storebytes_outside_inject; eauto. i. specialize (MS _ _ _ H5). clarify. + - inv H. eapply Mem.store_outside_inject; eauto. i. specialize (MS _ _ _ H). clarify. + Qed. + + Lemma bind_parameters_outside_mem_inject + ge cp e m_cur params vargs m_next + (BIND: bind_parameters ge cp e m_cur params vargs m_next) + k m + (INJ: Mem.inject k m m_cur) + (NIB: forall id b t, e ! id = Some (b, t) -> k b = None) + (MS: meminj_same_block k) + (* (NIB: not_inj_blks k (blocks_of_env2 ge e)) *) + : + Mem.inject k m m_next. + Proof. + revert_until BIND. induction BIND; ii. + { auto. } + apply IHBIND; auto. clear IHBIND. specialize (NIB _ _ _ H). + eapply assign_loc_outside_mem_inject; eauto. + Qed. + + Lemma not_inj_blks_get_env + k ge e + (NIB: not_inj_blks k (blocks_of_env2 ge e)) + : + forall id b t, e ! id = Some (b, t) -> k b = None. + Proof. + rr in NIB. unfold blocks_of_env2, blocks_of_env in NIB. rewrite map_map in NIB. + rewrite Forall_forall in NIB. i. apply PTree.elements_correct in H. + apply NIB. eapply (in_map (fun x : ident * (block * type) => fst (fst (block_of_binding ge x)))) in H. ss. + Qed. + + Lemma not_global_blks_get_env + (ge: genv) e + (NIB: not_global_blks ge (blocks_of_env2 ge e)) + : + forall id b t, e ! id = Some (b, t) -> (meminj_public ge) b = None. + Proof. eapply not_inj_blks_get_env. eapply not_global_is_not_inj_bloks. eauto. Qed. + + Lemma meminj_public_same_block + ge + : + meminj_same_block (meminj_public ge). + Proof. rr. unfold meminj_public. i. des_ifs. Qed. + + Lemma alloc_variables_mem_inject + ge cp e m params e' m' + (EA: alloc_variables ge cp e m params e' m') + k m0 + (INJ: Mem.inject k m0 m) + : + Mem.inject k m0 m'. + Proof. + revert_until EA. induction EA; ii. auto. + apply IHEA. clear IHEA. eapply Mem.alloc_right_inject; eauto. + Qed. + + Lemma mem_valid_access_wunchanged_on + m ch b ofs p cp + (MV: Mem.valid_access m ch b ofs p cp) + P m' + (WU: wunchanged_on P m m') + (SAT: forall ofs', P b ofs') + : + Mem.valid_access m' ch b ofs p cp. + Proof. + unfold Mem.valid_access in *. des. splits; auto. + - unfold Mem.range_perm in *. i. eapply perm_wunchanged_on; eauto. + - destruct cp. 2: ss. erewrite <- wunchanged_on_own; eauto. eapply Mem.can_access_block_valid_block; eauto. + Qed. + + Lemma mem_free_list_wunchanged_on_2 + l m cp m' + (FREE: Mem.free_list m l cp = Some m') + : + wunchanged_on (fun b _ => ~ In b (map (fun x => fst (fst x)) l)) m m'. + Proof. + revert_until l. induction l; ii. + { ss. clarify. apply wunchanged_on_refl. } + ss. des_ifs. eapply wunchanged_on_trans; cycle 1. + { eapply wunchanged_on_implies. eapply IHl. eauto. ss. i. apply Classical_Prop.not_or_and in H. des. auto. } + ss. eapply free_wunchanged_on. eapply Heq. ii. apply H0; clear H0. left; auto. + Qed. + + Lemma not_global_blks_global_not_in + (ge: genv) id b + (FIND: Genv.find_symbol ge id = Some b) + e + (NGB: not_global_blks ge (blocks_of_env2 ge e)) + : + ~ In b (map (fun x : block * Z * Z => fst (fst x)) (blocks_of_env ge e)). + Proof. + intros CONTRA. unfold not_global_blks in NGB. unfold blocks_of_env2, blocks_of_env in *. + rewrite map_map in NGB, CONTRA. rewrite Forall_forall in NGB. specialize (NGB _ CONTRA). + apply Genv.find_invert_symbol in FIND. setoid_rewrite FIND in NGB. inv NGB. + Qed. + + Lemma mem_free_list_unchanged_on + l m cp m' + (FREE: Mem.free_list m l cp = Some m') + : + Mem.unchanged_on (fun b _ => ~ In b (map (fun x => fst (fst x)) l)) m m'. + Proof. + revert_until l. induction l; ii. + { ss. clarify. apply Mem.unchanged_on_refl. } + ss. des_ifs. eapply Mem.unchanged_on_trans; cycle 1. + { eapply Mem.unchanged_on_implies. eapply IHl. eauto. ss. i. apply Classical_Prop.not_or_and in H. des. auto. } + ss. eapply Mem.free_unchanged_on. eapply Heq. ii. apply H0; clear H0. left; auto. + Qed. + + Lemma exists_vargs_vres + (ge1: Senv.t) (ge2: genv) + (MS: match_symbs ge1 ge2) + ef m1 vargs tr vretv m2 + (EK: external_call_known_observables ef ge1 m1 vargs tr vretv m2) + e cp le m_c + (WFE: wf_env ge2 e) + : + (eval_exprlist ge2 e cp le m_c (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) + (list_typ_to_typelist (sig_args (ef_sig ef))) vargs) /\ + (external_call ef ge2 vargs m_c tr vretv m_c). + Proof. + pose proof MS as MS0. destruct MS as (MS1 & MS2 & MS3). move MS0 after MS1. + unfold external_call_known_observables in *. des_ifs; ss; des. all: try (inv EK; clarify; ss). + - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. + esplits. + + econs. 3: econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. apply sem_cast_ptr. + + econs. econs; auto. rewrite MS3; auto. eapply match_symbs_eventval_match; eauto. + - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. + esplits. + + econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. apply sem_cast_ptr. + econs. 3: econs. + { instantiate (1:=v). destruct v; ss; try (econs; fail). + - destruct chunk; ss; inv H2; ss. + - destruct Archi.ptr64 eqn:ARCH. + + destruct chunk; ss; inv H2; ss; des_ifs. + * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. + eapply ptr_of_id_ofs_eval; eauto. + * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. + eapply ptr_of_id_ofs_eval; eauto. + + destruct chunk; ss; inv H2; ss; des_ifs. + * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. + eapply ptr_of_id_ofs_eval; eauto. + * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. + eapply ptr_of_id_ofs_eval; eauto. + * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. + eapply ptr_of_id_ofs_eval; eauto. + } + { rewrite EK1 in H2. + destruct v; ss. + - destruct chunk; ss; inv H2; ss. + - destruct chunk; ss. all: simpl_expr. inv H2. + - destruct chunk; ss. all: simpl_expr. + - destruct chunk; ss. inv H2. + - destruct chunk; ss. all: inv H2. + - inv H2. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. apply H7. intros INV2. rewrite INV2. + rewrite ptr_of_id_ofs_typeof. unfold Tptr. des_ifs; ss; simpl_expr. + + unfold Cop.sem_cast. ss. rewrite Heq. auto. + + unfold Cop.sem_cast. ss. rewrite Heq. auto. + } + + econs. econs; auto. rewrite MS3; auto. rewrite EK1. + rewrite EK1 in H2. eapply match_symbs_eventval_match; eauto. + - esplits. + + erewrite eventval_list_match_vals_to_eventvals. 2: eapply H. + erewrite <- eventval_list_match_list_eventval_to_list_val. + 2:{ eapply match_senv_eventval_list_match in H; eauto. } + eapply list_eventval_to_expr_val_eval; auto. eapply eventval_list_match_transl. + eapply match_senv_eventval_list_match; eauto. + + econs. eapply match_senv_eventval_list_match; eauto. + - esplits. + + econs. 3: econs. + * erewrite eventval_match_val_to_eventval. 2: eapply H. eapply eventval_to_expr_val_eval; auto. + eapply match_senv_eventval_match; eauto. + * erewrite eventval_match_val_to_eventval. 2: eapply H. + erewrite eventval_match_eventval_to_val. + 2:{ eapply match_senv_eventval_match; eauto. } + eapply eventval_match_sem_cast. eapply match_senv_eventval_match; eauto. + + econs. eapply match_senv_eventval_match; eauto. + Qed. + + Lemma eventval_list_match_eval_exprlist + (ge: genv) args targs vargs + (EMS: eventval_list_match ge args targs vargs) + e cp le m + (WF: wf_env ge e) + : + eval_exprlist ge e cp le m (list_eventval_to_list_expr args) + (list_eventval_to_typelist args) vargs. + Proof. + revert_until EMS. induction EMS; i; ss. econs. + econs; auto. + { clear dependent evl. clear tyl vl. inv H; try (simpl_expr; fail). + ss. eapply ptr_of_id_ofs_eval; auto. + } + { clear dependent evl. clear tyl vl. inv H; ss; try (simpl_expr; fail). + rewrite ptr_of_id_ofs_typeof. ss. + } + Qed. + + Lemma exists_vargs_vres_2 + (ge1: Senv.t) (ge2: genv) + (MS: match_symbs ge1 ge2) + ef m1 vargs tr vretv m2 + (EK: external_call_known_observables ef ge1 m1 vargs tr vretv m2) + e cp le m_c + (WFE: wf_env ge2 e) + : + exists vargs2 vretv2, + (eval_exprlist ge2 e cp le m_c (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) + (list_eventval_to_typelist (vals_to_eventvals ge1 vargs)) vargs2) /\ + (external_call ef ge2 vargs2 m_c tr vretv2 m_c). + Proof. + pose proof MS as MS0. destruct MS as (MS1 & MS2 & MS3). move MS0 after MS1. + unfold external_call_known_observables in *. des_ifs; ss; des. all: try (inv EK; clarify; ss). + - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. + esplits. + + econs. 3: econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. simpl_expr. + + econs. econs; auto. rewrite MS3; auto. eapply match_symbs_eventval_match; eauto. + - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. + esplits. + + econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. simpl_expr. + econs. 3: econs. + { instantiate (1:=v). destruct v; ss; try (econs; fail). + - destruct chunk; ss; inv H2; ss. + - destruct Archi.ptr64 eqn:ARCH. + + destruct chunk; ss; inv H2; ss; des_ifs. + * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. + eapply ptr_of_id_ofs_eval; eauto. + * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. + eapply ptr_of_id_ofs_eval; eauto. + + destruct chunk; ss; inv H2; ss; des_ifs. + * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. + eapply ptr_of_id_ofs_eval; eauto. + * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H6. intros INV2. rewrite INV2. + eapply ptr_of_id_ofs_eval; eauto. + * unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. eapply H7. intros INV2. rewrite INV2. + eapply ptr_of_id_ofs_eval; eauto. + } + { instantiate (1:=Val.load_result chunk v). rewrite EK1 in H2. rewrite EK1. + destruct v; ss. + - destruct chunk; ss; inv H2; ss. + - destruct chunk; ss. all: simpl_expr. + - destruct chunk; ss. all: simpl_expr. + - inv H2. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol. apply H7. intros INV2. rewrite INV2. + rewrite ptr_of_id_ofs_typeof. simpl_expr. + } + + econs. econs; auto. rewrite MS3; auto. rewrite EK1. eapply match_symbs_eventval_match; eauto. + - esplits. + + erewrite eventval_list_match_vals_to_eventvals. 2: eapply H. + eapply eventval_list_match_eval_exprlist; eauto. + eapply match_senv_eventval_list_match; eauto. + + econs. eapply match_senv_eventval_list_match; eauto. + - esplits. + + econs. 3: econs. + * erewrite eventval_match_val_to_eventval. 2: eapply H. eapply eventval_to_expr_val_eval; auto. + eapply match_senv_eventval_match; eauto. + * inv H; ss; try (simpl_expr; fail). apply MS2 in H1. setoid_rewrite H1. + rewrite ptr_of_id_ofs_typeof. ss. + + econs. eapply match_senv_eventval_match; eauto. + Qed. + + Lemma known_obs_preserves_mem + ef ge m vargs tr vretv m' + (EK: external_call_known_observables ef ge m vargs tr vretv m') + : + m' = m. + Proof. + unfold external_call_known_observables in EK. des_ifs; des; inv EK; clarify. inv H; clarify. + Qed. + + Lemma meminj_first_order_public_first_order + ge m + (MFO: meminj_first_order (meminj_public ge) m) + : + public_first_order ge m. + Proof. + ii. apply MFO; auto. unfold meminj_public. apply Senv.find_invert_symbol in FIND. + rewrite FIND. rewrite PUBLIC. ss. + Qed. + + Lemma vals_public_eval_to_vargs + (ge: genv) ef vargs + (VP: vals_public ge (sig_args (ef_sig ef)) vargs) + e cp le m + (WFE: wf_env ge e) + : + eval_exprlist ge e cp le m + (list_eventval_to_list_expr (vals_to_eventvals ge vargs)) + (list_typ_to_typelist (sig_args (ef_sig ef))) vargs. + Proof. + induction VP. ss. econs. ss. rename x into ty, y into v. econs. 3: auto. + - clear dependent l. clear dependent l'. + inv H; ss; try (simpl_expr; fail). + destruct H0 as (id & BP1 & BP2). + unfold senv_invert_symbol_total. rewrite BP1. + apply ptr_of_id_ofs_eval; auto. apply Senv.invert_find_symbol; auto. + - clear dependent l. clear dependent l'. + inv H; ss; try (simpl_expr; fail). + destruct H0 as (id & BP1 & BP2). + unfold senv_invert_symbol_total. rewrite BP1. + rewrite ptr_of_id_ofs_typeof. unfold Tptr. des_ifs; ss. + + unfold Cop.sem_cast. ss. rewrite Heq. ss. + + unfold Cop.sem_cast. ss. rewrite Heq. ss. + Qed. + + Lemma vals_public_eval_to_vargs_2 + (ge: genv) ef vargs + (VP: vals_public ge (sig_args (ef_sig ef)) vargs) + e cp le m + (WFE: wf_env ge e) + : + eval_exprlist ge e cp le m + (list_eventval_to_list_expr (vals_to_eventvals ge vargs)) + (list_eventval_to_typelist (vals_to_eventvals ge vargs)) vargs. + Proof. + induction VP. ss. econs. ss. rename x into ty, y into v. econs. 3: auto. + - clear dependent l. clear dependent l'. + inv H; ss; try (simpl_expr; fail). + destruct H0 as (id & BP1 & BP2). + unfold senv_invert_symbol_total. rewrite BP1. + apply ptr_of_id_ofs_eval; auto. apply Senv.invert_find_symbol; auto. + - clear dependent l. clear dependent l'. + inv H; ss; try (simpl_expr; fail). + destruct H0 as (id & BP1 & BP2). + unfold senv_invert_symbol_total. rewrite BP1. + rewrite ptr_of_id_ofs_typeof. ss. + Qed. + + Lemma match_symbs_block_public + ge1 ge2 + (MS: match_symbs ge1 ge2) + b + (BP: block_public ge1 b) + : + block_public ge2 b. + Proof. + destruct MS as (MS1 & MS2 & MS3). destruct BP as (id & BP1 & BP2). + apply Senv.invert_find_symbol in BP1. apply MS2 in BP1. rewrite <- MS1 in BP2. + unfold block_public. esplits; eauto. apply Senv.find_invert_symbol; auto. + Qed. + + Lemma match_symbs_vals_public + ge1 ge2 + (MS: match_symbs ge1 ge2) + tys vargs + (VP: vals_public ge1 tys vargs) + : + vals_public ge2 tys vargs. + Proof. + induction VP; ss. econs; auto. clear VP IHVP. inv H; econs; auto. + eapply match_symbs_block_public; eauto. + Qed. + + Lemma match_symbs_vals_public_vals_to_eventvals + ge1 ge2 + (MS: match_symbs ge1 ge2) + tys vargs + (VP: vals_public ge1 tys vargs) + : + vals_to_eventvals ge1 vargs = vals_to_eventvals ge2 vargs. + Proof. + induction VP; ss. f_equal; auto. clear dependent l. clear dependent l'. + inv H; ss. destruct H0 as (id & BP1 & BP2). + unfold senv_invert_symbol_total at 1. des_ifs. + destruct MS as (MS0 & MS1 & MS2). + apply Senv.invert_find_symbol in Heq. apply MS1 in Heq. + unfold senv_invert_symbol_total at 1. apply Senv.find_invert_symbol in Heq. + rewrite Heq. auto. + Qed. + + Lemma match_symbs_vals_public_eval_to_vargs + ge1 (ge2: genv) + (MS: match_symbs ge1 ge2) + ef vargs + (VP: vals_public ge1 (sig_args (ef_sig ef)) vargs) + e cp le m + (WFE: wf_env ge2 e) + : + eval_exprlist ge2 e cp le m + (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) + (list_typ_to_typelist (sig_args (ef_sig ef))) vargs. + Proof. + erewrite match_symbs_vals_public_vals_to_eventvals; eauto. + eapply vals_public_eval_to_vargs; auto. eapply match_symbs_vals_public; eauto. + Qed. + + Lemma match_symbs_vals_public_eval_to_vargs_2 + ge1 (ge2: genv) + (MS: match_symbs ge1 ge2) + ef vargs + (VP: vals_public ge1 (sig_args (ef_sig ef)) vargs) + e cp le m + (WFE: wf_env ge2 e) + : + eval_exprlist ge2 e cp le m + (list_eventval_to_list_expr (vals_to_eventvals ge1 vargs)) + (list_eventval_to_typelist (vals_to_eventvals ge1 vargs)) vargs. + Proof. + erewrite match_symbs_vals_public_vals_to_eventvals; eauto. + eapply vals_public_eval_to_vargs_2; auto. eapply match_symbs_vals_public; eauto. + Qed. + + Lemma extcall_unkowns_vals_public + ef ge m vargs + (EC: external_call_unknowns ef ge m vargs) + : + vals_public ge (sig_args (ef_sig ef)) vargs. + Proof. + unfold external_call_unknowns in EC. des_ifs; ss; auto. + all: destruct EC as (EC1 & EC2); auto. + Qed. + + + Lemma mem_unchanged_wunchanged + P m m' + (UCH: Mem.unchanged_on P m m') + : + wunchanged_on P m m'. + Proof. inv UCH. econs; eauto. Qed. + + Lemma meminj_public_not_public_not_mapped + ge cnt_cur + (NP: Senv.public_symbol ge cnt_cur = false) + cnt_cur_b + (FIND: Senv.find_symbol ge cnt_cur = Some cnt_cur_b) + : + forall b ofs, meminj_public ge b <> Some (cnt_cur_b, ofs). + Proof. + ii. unfold meminj_public in H. des_ifs. + assert (i = cnt_cur). + { eapply Senv.find_symbol_injective; eauto. apply Senv.invert_find_symbol; auto. } + subst i. rewrite NP in Heq0. ss. + Qed. + + + Lemma wunchanged_on_exists_mem_free_gen + m1 b lo hi cp m2 + (FREE: Mem.free m1 b lo hi cp = Some m2) + (P: block -> Prop) m_c + (WCH: wunchanged_on (fun b _ => P b) m1 m_c) + (NGB: P b) + : + exists m_c', Mem.free m_c b lo hi cp = Some m_c'. + Proof. + hexploit Mem.free_range_perm; eauto. hexploit Mem.free_can_access_block_1; eauto. i. + hexploit Mem.range_perm_free. + 3:{ intros (m0 & F). eexists; eapply F. } + - unfold Mem.range_perm in *. i. eapply perm_wunchanged_on. 3: eauto. eauto. ss. + - rewrite <- wunchanged_on_own; eauto. eapply Mem.can_access_block_valid_block. eauto. + Qed. + + Lemma wunchanged_on_exists_mem_free_2 + m1 b lo hi cp m2 + (FREE: Mem.free m1 b lo hi cp = Some m2) + ge m_c + (WCH: wunchanged_on (fun b _ => Senv.invert_symbol ge b = None) m1 m_c) + (NGB: Senv.invert_symbol ge b = None) + : + exists m_c', Mem.free m_c b lo hi cp = Some m_c'. + Proof. eapply wunchanged_on_exists_mem_free_gen; eauto. eapply WCH. ss. Qed. + + Lemma wunchanged_on_free_preserves_gen + P m m' + (WU : wunchanged_on P m m') + b lo hi cp m1 m1' + (FREE: Mem.free m b lo hi cp = Some m1) + (FREE': Mem.free m' b lo hi cp = Some m1') + : + wunchanged_on P m1 m1'. + Proof. + inv WU. econs. + - rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE). rewrite (Mem.nextblock_free _ _ _ _ _ _ FREE'). auto. + - i. assert (VB: Mem.valid_block m b0). + { eapply Mem.valid_block_free_2; eauto. } + split; i. + + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE _ _ _ _ H1). rewrite wunchanged_on_perm in H2; auto. + eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. + hexploit Mem.perm_free_2. eapply FREE. split; eauto. i. exfalso. apply H2. eapply H1. + + pose proof (Mem.perm_free_3 _ _ _ _ _ _ FREE' _ _ _ _ H1). rewrite <- wunchanged_on_perm in H2; auto. + eapply Mem.perm_free_inv in H2. 2: eauto. des; auto. clarify. + hexploit Mem.perm_free_2. eapply FREE'. split; eauto. i. exfalso. apply H2. eapply H1. + - i. assert (VB: Mem.valid_block m b0). + { eapply Mem.valid_block_free_2; eauto. } + split; i. + + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. + eapply Mem.free_can_access_block_inj_2; eauto. + + eapply Mem.free_can_access_block_inj_1; eauto. apply wunchanged_on_own; auto. + eapply Mem.free_can_access_block_inj_2; eauto. + Qed. + + Lemma wunchanged_on_exists_mem_free_list_gen + l m1 cp m2 + (FREE: Mem.free_list m1 l cp = Some m2) + (P: block -> Prop) m_c + (WCH: wunchanged_on (fun b _ => P b) m1 m_c) + (NGB: Forall P (map (fun x => fst (fst x)) l)) + : + exists m_c', Mem.free_list m_c l cp = Some m_c'. + Proof. + revert_until l. induction l; i; ss. eauto. + destruct a as ((b & lo) & hi). ss. inv NGB. des_ifs; ss. + 2:{ exfalso. hexploit wunchanged_on_exists_mem_free_gen. 2: eapply WCH. all: eauto. + intros. des. rewrite H in Heq; clarify. + } + hexploit IHl. eapply FREE. 2: eapply H2. + { instantiate (1:=m). eapply wunchanged_on_free_preserves_gen; eauto. } + eauto. + Qed. + + Lemma wunchanged_on_exists_mem_free_list_2 + l m1 cp m2 + (FREE: Mem.free_list m1 l cp = Some m2) + ge m_c + (WCH: wunchanged_on (fun b _ => Senv.invert_symbol ge b = None) m1 m_c) + (NGB: not_global_blks ge (map (fun x => fst (fst x)) l)) + : + exists m_c', Mem.free_list m_c l cp = Some m_c'. + Proof. eapply wunchanged_on_exists_mem_free_list_gen; eauto. ss. Qed. + + Lemma wunchanged_on_free_list_preserves_gen + P m m' + (WU: wunchanged_on P m m') + l cp m_f m_f' + (FREE: Mem.free_list m l cp = Some m_f) + (FREE': Mem.free_list m' l cp = Some m_f') + : + wunchanged_on P m_f m_f'. + Proof. + move l after m. revert_until l. induction l; ii; ss. clarify. + des_ifs. eapply IHl. 2,3: eauto. eapply wunchanged_on_free_preserves_gen; eauto. + Qed. + + Lemma meminj_not_alloc_external_call + j m1 + (NA: meminj_not_alloc j m1) + ef ge vargs tr vretv m2 + (EC: external_call ef ge vargs m1 tr vretv m2) + : + meminj_not_alloc j m2. + Proof. + unfold meminj_not_alloc in *. i. apply NA. clear NA. + eapply external_call_nextblock in EC. etransitivity. 2: eapply H. auto. + Qed. + + Lemma public_first_order_meminj_first_order + (ge: Senv.t) m + (FO: public_first_order ge m) + : + meminj_first_order (meminj_public ge) m. + Proof. + ii. unfold meminj_public in H. des_ifs. eapply FO; eauto. + apply Senv.invert_find_symbol; auto. + Qed. + + Lemma list_length_filter_le + A P (l: list A) + : + (Datatypes.length (filter P l) <= Datatypes.length l)%nat. + Proof. + induction l; ss. des_ifs; ss; auto. rewrite <- Nat.succ_le_mono. auto. + Qed. + +End PROOF. diff --git a/security/BacktranslationProof.v b/security/BacktranslationProof.v new file mode 100644 index 0000000000..267e88c557 --- /dev/null +++ b/security/BacktranslationProof.v @@ -0,0 +1,2229 @@ +Require Import String. +Require Import Coqlib Maps Errors Integers Values Memory Globalenvs. +Require Import AST Linking Smallstep Events Behaviors. + +Require Import Split. + +Require Import Tactics. +Require Import riscV.Asm. +Require Import BtBasics BtInfoAsm MemoryDelta MemoryWeak. +Require Import Ctypes Clight. +Require Import Backtranslation BacktranslationAux. + + + +Section INVS. + + Definition cnt_ids := PTree.t ident. + + Definition wf_counter (ge: Senv.t) (m: mem) cp (n: nat) (cnt: ident): Prop := + (Senv.public_symbol ge cnt = false) /\ + exists b, (Senv.find_symbol ge cnt = Some b) /\ + (Mem.valid_access m Mint64 b 0 Writable (Some cp)) /\ + (Mem.loadv Mint64 m (Vptr b Ptrofs.zero) (Some cp) = Some (Vlong (nat64 n))). + + Definition wf_counters (ge_a: Asm.genv) (ge: Clight.genv) (m: mem) (tr: bundle_trace) (cnts: cnt_ids) := + (forall id0 id1 cnt, (cnts ! id0 = Some cnt) -> (cnts ! id1 = Some cnt) -> (id0 = id1)) /\ + (forall id b gd, + (Genv.find_symbol ge_a id = Some b) -> + (Genv.find_def ge_a b = Some gd) -> + (exists cnt, (cnts ! id = Some cnt) /\ + (wf_counter ge m (comp_of gd) (length (get_id_tr tr id)) cnt))). + + Inductive wf_c_cont (ge: Clight.genv) : mem -> cont -> Prop := + | wf_c_cont_nil + m + : + wf_c_cont ge m Kstop + | wf_c_cont_cons + m ck + f e le s1 s2 m' ck' + (WFENV: wf_env ge e) + (NINJ: not_global_blks (ge) (blocks_of_env2 ge e)) + (CK: ck = Kcall None f e le (Kloop1 s1 s2 ck')) + (FREE: Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m') + (IND: wf_c_cont ge m' ck') + : + wf_c_cont ge m ck. + + Definition wf_c_stmt (ge: Senv.t) cp cnts id tr stmt := + forall cnt, (cnts ! id = Some cnt) -> stmt = code_bundle_trace ge cp cnt (get_id_tr tr id). + + Definition wf_c_nb (ge: Clight.genv) (m: mem) := + (Genv.genv_next ge <= Mem.nextblock m)%positive. + + Definition wf_c_state ge_a (ge: Clight.genv) (tr ttr: bundle_trace) (cnts: cnt_ids) id (cst: Clight.state) := + match cst with + | State f stmt k_c e le m_c => + wf_counters ge_a ge m_c tr cnts /\ + (exists m_c', Mem.free_list m_c (blocks_of_env ge e) (comp_of f) = Some m_c' /\ wf_c_cont ge m_c' k_c) /\ + wf_c_stmt ge (comp_of f) cnts id ttr stmt /\ + (wf_env ge e /\ (not_global_blks (ge) (blocks_of_env2 ge e)) /\ (wf_c_nb ge m_c)) + | _ => False + end. + + Definition match_genv (ge: Asm.genv) (ge': genv) := + (match_symbs ge ge') /\ (eq_policy ge ge'). + + Definition match_mem (ge: Senv.t) (k: meminj) (m_i m_c: mem): Prop := + let j := meminj_public ge in + (Mem.inject k m_i m_c) /\ (inject_incr j k) /\ (meminj_not_alloc j m_i). + + Definition match_cur_fun (ge_i: Asm.genv) (ge_c: genv) (cur: block) f (id: ident): Prop := + (Genv.find_funct_ptr ge_c cur = Some (Internal f)) /\ + (exists f_i, Genv.find_funct_ptr ge_i cur = Some (AST.Internal f_i)) /\ + (Genv.invert_symbol ge_i cur = Some id). + + Definition match_find_def (ge_i: Asm.genv) (ge_c: Clight.genv) (cnts: cnt_ids) (pars: params_of) tr := + forall b gd_i id, + Genv.find_def ge_i b = Some gd_i -> + Senv.invert_symbol ge_i b = Some id -> + match (cnts ! id), (pars ! id) with + | Some cnt, Some params => + Genv.find_def ge_c b = Some (gen_globdef ge_i cnt params (get_id_tr tr id) gd_i) + | _, _ => False + end. + + Inductive match_cont (ge: Clight.genv) (tr: bundle_trace) (cnts: cnt_ids) : (cont) -> (ir_conts) -> Prop := + | match_cont_nil + ck ik + (CK: ck = Kstop) + (IK: ik = nil) + : + match_cont ge tr cnts ck ik + | match_cont_cons + ck ik + f e le cnt id ck' + b ik' + (FUN: Genv.find_funct_ptr ge b = Some (Internal f)) + (ID: Genv.invert_symbol ge b = Some id) + (CNT: cnts ! id = Some cnt) + (CK: ck = Kcall None f e le (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge cnt (comp_of f) (get_id_tr tr id))) Sskip ck')) + (IK: ik = (ir_cont b) :: ik') + (IND: match_cont ge tr cnts ck' ik') + : + match_cont ge tr cnts ck ik. + + Definition match_params pars (ge_c: genv) (ge_i: Asm.genv) := + (wf_params_of pars) /\ (wf_params_of_sig pars ge_i) /\ (wf_params_of_symb pars ge_c). + + Definition match_cnts cnts (ge_c: genv) (k: meminj) := + forall id cnt cnt_b, (cnts ! id = Some cnt) -> (Genv.find_symbol ge_c cnt = Some cnt_b) -> + (forall b ofs, k b <> Some (cnt_b, ofs)). + + Definition match_state (ge_i: Asm.genv) (ge_c: Clight.genv) (k: meminj) tr cnts pars id (ist: ir_state) (cst: Clight.state) := + match ist, cst with + | Some (cur, m_i, k_i), State f _ k_c e le m_c => + (match_genv ge_i ge_c) /\ (match_mem ge_i k m_i m_c) /\ + (match_cur_fun ge_i ge_c cur f id) /\ (match_find_def ge_i ge_c cnts pars tr) /\ + (match_cont ge_c tr cnts k_c k_i) /\ + (match_params pars ge_c ge_i) /\ + (match_cnts cnts ge_c k) + | _, _ => False + end. + +End INVS. + + + +Section PROOF. + + Lemma cur_fun_def + ge_i (ge_c: genv) cur f (f_i_cur : Asm.function) id_cur cnts pars ttr + (FINDF_C_CUR : Genv.find_funct_ptr ge_c cur = Some (Internal f)) + (FINDF_I_CUR : Genv.find_funct_ptr ge_i cur = Some (AST.Internal f_i_cur)) + (INV_CUR : Genv.invert_symbol ge_i cur = Some id_cur) + (MS3 : match_find_def ge_i ge_c cnts pars ttr) + : + exists cnt_cur params_cur, + (cnts ! id_cur = Some cnt_cur) /\ (pars ! id_cur = Some params_cur) /\ + (f = gen_function ge_i cnt_cur params_cur (get_id_tr ttr id_cur) f_i_cur). + Proof. + exploit MS3. eapply Genv.find_funct_ptr_iff. eauto. eapply INV_CUR. intros. des_ifs. + esplits; eauto. apply Genv.find_funct_ptr_iff in FINDF_C_CUR. + setoid_rewrite FINDF_C_CUR in x0. unfold gen_globdef in x0. clarify. + Qed. + + Lemma wf_c_cont_wunchanged_on + ge m k + (WFC: wf_c_cont ge m k) + m' + (WU: wunchanged_on (fun b _ => Mem.valid_block m b) m m') + : + wf_c_cont ge m' k. + Proof. + revert_until WFC. induction WFC; ii. econs. + clarify. + hexploit wunchanged_on_exists_mem_free_list. eapply WU. eapply FREE. intros (m_f & FREE2). + econs. 1,2,3: eauto. eapply FREE2. eapply IHWFC. + eapply wunchanged_on_free_list_preserves. eapply WU. all: eauto. + Qed. + + Lemma star_cut_middle + stepk ge_a ge_c cst1 ev pretr ttr cnts ge_i pars ist2 + (CUT: exists tr1 cst', + (star stepk ge_c cst1 tr1 cst') /\ + exists tr2 cst2, + (star stepk ge_c cst' tr2 cst2) /\ + ((exists id', (wf_c_state ge_a ge_c (pretr ++ [ev]) ttr cnts id' cst2) /\ + exists k, (match_state ge_i ge_c k ttr cnts pars id' ist2 cst2)) + \/ (ist2 = None)) /\ + (unbundle ev = tr1 ++ tr2)) + : + exists cst2, (star stepk ge_c cst1 (unbundle ev) cst2) /\ + ((exists id', (wf_c_state ge_a ge_c (pretr ++ [ev]) ttr cnts id' cst2) /\ + exists k, (match_state ge_i ge_c k ttr cnts pars id' ist2 cst2)) + \/ (ist2 = None)). + Proof. + destruct CUT as (tr1 & cts' & STAR1 & tr2 & cst2 & STAR2 & PROP & TR). + exists cst2. split; auto. eapply star_trans. eapply STAR1. eapply STAR2. auto. + Qed. + + Lemma mem_inject_incr_match_cnts_rev + k1 k2 + (INCR: inject_incr k1 k2) + cnts ge + (MC: match_cnts cnts ge k2) + : + match_cnts cnts ge k1. + Proof. + unfold match_cnts in *. i. specialize (MC _ _ _ H H0 b ofs). ii. apply MC; clear MC. apply INCR. auto. + Qed. + + Lemma wf_c_cont_wunchanged_on_2 + ge m k + (WF: wf_c_cont ge m k) + m' + (WCH: wunchanged_on (fun b _ => Senv.invert_symbol ge b = None) m m') + : + wf_c_cont ge m' k. + Proof. + revert_until WF. induction WF; i; ss. econs. + clarify. hexploit wunchanged_on_exists_mem_free_list_2. + eapply FREE. instantiate (2:=ge). eapply WCH. auto. + intros (m_c' & FREE2). + econs. eauto. auto. eauto. eapply FREE2. eapply IHWF. + eapply wunchanged_on_free_list_preserves_gen. 2,3: eauto. auto. + Qed. + + Lemma wf_c_nb_wunchanged_on + P m1 m2 + (WCH: wunchanged_on P m1 m2) + ge + (WFNB: wf_c_nb ge m1) + : + wf_c_nb ge m2. + Proof. + unfold wf_c_nb in *. hexploit wunchanged_on_nextblock. eapply WCH. + intros. etransitivity. eapply WFNB. auto. + Qed. + + + + Lemma ir_to_clight_step_cce_1 + (ge_i: Asm.genv) (ge_c: genv) + (WFGE : wf_ge ge_i) + cnts pars k_i cur m_i pretr btr (tr tr' : trace) id0 evargs ef id_cur d + (BOUND : Z.of_nat + (Datatypes.length + (pretr ++ (id_cur, Bundle_call tr' id0 evargs (ef_sig ef) d) :: btr)) < + Int64.modulus) + k_c id f stmt k0 e le m_c + (MS0 : match_genv ge_i ge_c) + (MS1 : match_mem ge_i k_c m_i m_c) + (MS2 : match_cur_fun ge_i ge_c cur f id) + (MS4 : match_cont ge_c (pretr ++ (id_cur, Bundle_call tr' id0 evargs (ef_sig ef) d) :: btr) cnts + k0 k_i) + (MS3 : match_find_def ge_i ge_c cnts pars + (pretr ++ (id_cur, Bundle_call tr' id0 evargs (ef_sig ef) d) :: btr)) + (MS5 : match_params pars ge_c ge_i) + (MCNTS : match_cnts cnts ge_c k_c) + (CNT_INJ : forall (id0 id1 : positive) (cnt : ident), + cnts ! id0 = Some cnt -> cnts ! id1 = Some cnt -> id0 = id1) + (WFC0 : forall (id : ident) (b : block) gd, + Genv.find_symbol ge_i id = Some b -> + Genv.find_def ge_i b = Some gd -> + exists cnt : ident, + cnts ! id = Some cnt /\ + wf_counter ge_c m_c (comp_of gd) (Datatypes.length (get_id_tr pretr id)) cnt) + m_freeenv + (FREEENV : Mem.free_list m_c (blocks_of_env ge_c e) (comp_of f) = Some m_freeenv) + (WFC1 : wf_c_cont ge_c m_freeenv k0) + (WFC2 : wf_c_stmt ge_c (comp_of f) cnts id + (pretr ++ (id_cur, Bundle_call tr' id0 evargs (ef_sig ef) d) :: btr) stmt) + (WFC3 : wf_env ge_c e) + (WFC4 : not_global_blks ge_c (blocks_of_env2 ge_c e)) + (WFNB : wf_c_nb ge_c m_c) + vargs b + (FINDB : Genv.find_symbol ge_i id0 = Some b) + (FINDF : Genv.find_funct ge_i (Vptr b Ptrofs.zero) = Some (AST.External ef)) + (NPTR : crossing_comp ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) (comp_of ef) -> + Forall not_ptr vargs) + (ALLOW : Genv.allowed_call ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) + (Vptr b Ptrofs.zero)) + (TR : call_trace_cross ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) + (comp_of ef) b vargs (sig_args (ef_sig ef)) tr id0 evargs) + (IDCUR : Genv.invert_symbol ge_i cur = Some id_cur) + m2 + (DELTA: mem_delta_apply_wf ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) d (Some m_i) = Some m2) + (DELTA_CASES: (public_first_order ge_i m2) \/ (d = [])) + (TR_APP: exists tr0, tr' = tr ++ tr0) + : + exists cnt_cur cnt_cur_b, + (cnts ! id_cur = Some cnt_cur /\ Senv.find_symbol ge_c cnt_cur = Some cnt_cur_b /\ Senv.public_symbol ge_c cnt_cur = false) /\ + let dsg := from_sig_fun_data (ef_sig ef) in + let fd_next := (External ef (dargs dsg) (dret dsg) (dcc dsg)) in + exists m_c', + (star step1 ge_c (State f stmt k0 e le m_c) + (tr) + (Callstate fd_next vargs + (Kcall None f e le (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_cur (comp_of f) (get_id_tr (pretr ++ (id_cur, Bundle_call tr' id0 evargs (ef_sig ef) d) :: btr) id_cur))) Sskip k0)) m_c')) + /\ + (exists m_cu, + (Mem.storev Mint64 m_c (Vptr cnt_cur_b Ptrofs.zero) (Vlong (Int64.add (nat64 (Datatypes.length (map (fun ib : ident * bundle_event => code_bundle_event ge_i (comp_of f) (snd ib)) (get_id_tr pretr id_cur)))) Int64.one)) (comp_of f) = Some m_cu) /\ + (d = [] -> m_c' = m_cu) /\ + ((public_first_order ge_i m2) -> + (mem_delta_apply_wf ge_i (comp_of f) d (Some m_cu) = Some m_c') /\ + (Mem.inject (meminj_public ge_i) m2 m_c'))) + . + Proof. + assert (id = id_cur). + { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } + subst id. + destruct MS2 as (FINDF_C_CUR & (f_i_cur & FINDF_I_CUR) & INV_CUR). + + exploit MS3. + { eapply Genv.find_funct_ptr_iff. erewrite <- Genv.find_funct_find_funct_ptr. eapply FINDF. } + { eapply Genv.find_invert_symbol; eauto. } + intros FINDF_C. des_ifs. rename id0 into id_next, i into cnt_next, Heq into CNTS_NEXT, l into params_next, Heq0 into PARS_NEXT. simpl in FINDF_C. + set (pretr ++ (id_cur, Bundle_call tr' id_next evargs (ef_sig ef) d) :: btr) as ttr in *. + assert (FIND_CUR_I: Genv.find_symbol ge_i id_cur = Some cur). + { apply Genv.invert_find_symbol in IDCUR. auto. } + assert (FIND_CUR_C: Genv.find_symbol ge_c id_cur = Some cur). + { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply MSENV1 in FIND_CUR_I. auto. } + assert (FIND_FUN_C: Genv.find_funct_ptr ge_c cur = Some (Internal f)). + { auto. } + + exploit WFC0. eapply FIND_CUR_I. rewrite <- Genv.find_funct_ptr_iff; eapply FINDF_I_CUR. + intros (cnt_cur & CNTS_CUR & WF_CNT_CUR). + destruct WF_CNT_CUR as (CNT_CUR_NPUB & cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). + exists cnt_cur, cnt_cur_b. split. auto. + set (Kcall None f e le (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_cur (comp_of f) (get_id_tr ttr id_cur))) Sskip k0)) as kc_next. + assert (CUR_TR: get_id_tr ttr id_cur = (get_id_tr pretr id_cur) ++ (id_cur, Bundle_call tr' id_next evargs (ef_sig ef) d) :: (get_id_tr btr id_cur)). + { subst ttr. clear. rewrite get_id_tr_app. rewrite get_id_tr_cons. ss. rewrite Pos.eqb_refl. auto. } + assert (BOUND2: Z.of_nat (Datatypes.length (map (fun ib : ident * bundle_event => code_bundle_event ge_i (comp_of f) (snd ib)) (get_id_tr ttr id_cur))) < Int64.modulus). + { rewrite map_length. eapply Z.le_lt_trans. 2: eauto. unfold get_id_tr. + apply inj_le. apply list_length_filter_le. + } + + hexploit cur_fun_def. eapply FINDF_C_CUR. eapply FINDF_I_CUR. eapply IDCUR. eauto. + intros (cnt_cur0 & params_cur & CNT_CUR0 & PARAMS_CUR & CUR_F). + rewrite CNTS_CUR in CNT_CUR0. inversion CNT_CUR0. subst cnt_cur0. clear CNT_CUR0. + assert (CP_CUR: (comp_of f) = (Genv.find_comp ge_i (Vptr cur Ptrofs.zero))). + { unfold Genv.find_comp. setoid_rewrite FINDF_I_CUR. subst f. ss. } + assert (COMP_CUR_EQ: comp_of (@Gfun _ unit (AST.Internal f_i_cur)) = comp_of f). + { subst f. ss. } + setoid_rewrite COMP_CUR_EQ in CNT_CUR_MEM_VA. setoid_rewrite COMP_CUR_EQ in CNT_CUR_MEM_LOAD. + + hexploit switch_spec. + { subst ttr. rewrite CUR_TR in BOUND2. rewrite map_app in BOUND2. ss. eapply BOUND2. } + { unfold wf_env in WFC3. specialize (WFC3 cnt_cur). des_ifs. eapply WFC3. } + eapply FIND_CNT_CUR. eapply CNT_CUR_MEM_VA. + { rewrite CNT_CUR_MEM_LOAD. rewrite map_length. auto. } + instantiate (1:=le). + instantiate (1:=(Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_cur (comp_of f) (get_id_tr ttr id_cur))) Sskip k0)). + instantiate (1:=Sreturn None). + intros (m_cu & CNT_CUR_STORE & CUR_SWITCH_STAR). + + assert (DELTA_C: exists m_c', + (mem_delta_apply_wf ge_i (comp_of f) d (Some m_cu) = Some m_c') /\ + (((public_first_order ge_i m2) -> (Mem.inject (meminj_public ge_i) m2 m_c')))). + { move MS1 after CUR_SWITCH_STAR. destruct MS1 as (MINJ & INJINCR & NALLOC). + move DELTA after NALLOC. + hexploit mem_delta_apply_establish_inject_preprocess_gen. + apply MINJ. eapply CNT_CUR_STORE. + { instantiate (1:=ge_i). erewrite match_symbs_meminj_public. 2: destruct MS0 as (MS & _); apply MS. + ii. eapply meminj_public_not_public_not_mapped. 3: apply H. 2: eauto. auto. + } + apply INJINCR. apply NALLOC. apply DELTA. + intros (m_c' & DELTA' & INJ'). exists m_c'. splits; auto. + rewrite CP_CUR. auto. i. apply INJ'. apply public_first_order_meminj_first_order; auto. + } + desH DELTA_C. rename DELTA_C0 into MEMINJ_CNT. + + exists m_c'. split; cycle 1. + { exists m_cu. split; auto. split. + - i. subst d. unfold mem_delta_apply_wf in DELTA_C. ss. clarify. + - i. split; auto. + } + + unfold wf_c_stmt in WFC2. specialize (WFC2 _ CNTS_CUR). subst stmt. + eapply star_trans. eapply code_bundle_trace_spec. 2: ss. + unfold switch_bundle_events at 1. rewrite CUR_TR at 1. rewrite map_app. simpl. + rewrite ! (match_symbs_code_bundle_call ge_i ge_c) in CUR_SWITCH_STAR. + rewrite ! (match_symbs_code_bundle_events ge_i ge_c) in CUR_SWITCH_STAR. + eapply star_trans. eapply CUR_SWITCH_STAR. 2: ss. 2,3: apply MS0. + clear BOUND2 CUR_SWITCH_STAR. + unfold code_bundle_call. eapply star_trans. eapply code_mem_delta_correct. auto. + { erewrite <- match_symbs_mem_delta_apply_wf. eapply DELTA_C. apply MS0. } + 2: ss. + unfold unbundle. simpl. rename b into next. + + assert (CP_NEXT: (Genv.find_comp ge_c (Vptr next Ptrofs.zero)) = (comp_of ef)). + { unfold Genv.find_comp. apply Genv.find_funct_ptr_iff in FINDF_C. setoid_rewrite FINDF_C. ss. } + assert (EVARGS: list_eventval_to_list_val ge_c evargs = vargs). + { destruct MS0 as (MSENV & MGENV). inv TR. + eapply eventval_list_match_list_eventval_to_list_val. eapply match_symbs_eventval_list_match; eauto. + } + + econs 2. + { eapply step_call. ss. + { econs. assert (FSN_C: Senv.find_symbol ge_c id_next = Some next). + { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply MSENV1. auto. } + eapply eval_Evar_global. + - unfold wf_env in WFC3. specialize (WFC3 id_next). rewrite FSN_C in WFC3. apply WFC3. + - eapply FSN_C. + - econs 2. ss. + } + { eapply list_eventval_to_expr_val_eval. auto. inv TR. eapply eventval_list_match_transl. eapply match_senv_eventval_list_match; eauto. destruct MS0 as (MSENV & _); auto. } + { unfold match_find_def in MS3. hexploit MS3. + unfold Genv.find_funct in FINDF. rewrite pred_dec_true in FINDF; auto. unfold Genv.find_funct_ptr in FINDF. des_ifs. eapply Heq. + eapply Senv.find_invert_symbol; eapply FINDB. + rewrite CNTS_NEXT, PARS_NEXT. intros. unfold Genv.find_funct. rewrite pred_dec_true. unfold Genv.find_funct_ptr. rewrite H. ss. ss. + } + { ss. } + { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). + subst f. setoid_rewrite CP_CUR. move ALLOW after EVARGS. + eapply allowed_call_gen_function_external; eauto. + setoid_rewrite Genv.find_funct_ptr_iff. auto. + } + { move NPTR after EVARGS. move TR after NPTR. i. + rewrite EVARGS. apply NPTR. unfold crossing_comp. rewrite <- H. + setoid_rewrite CP_CUR. rewrite CP_NEXT. auto. + } + { move TR after EVARGS. instantiate (1:=tr). inv TR. + setoid_rewrite CP_CUR. rewrite CP_NEXT. + econs 2. + { rewrite <- H. ss. } + eauto. + { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply Genv.find_invert_symbol. apply MSENV1. auto. } + { eapply eventval_list_match_transl. eapply match_senv_eventval_list_match; eauto. destruct MS0 as (MSENV & _); auto. } + } + } + { rewrite EVARGS. subst kc_next. econs 1. } + traceEq. + Qed. + + Lemma ir_to_clight_step_cce_2 + (ge_i: Asm.genv) (ge_c: genv) + (WFGE : wf_ge ge_i) + cnts pars k_i cur m_i pretr btr (tr1 tr2 tr' : trace) id0 vargs ef id_cur d + (BOUND : Z.of_nat + (Datatypes.length + (pretr ++ (id_cur, Bundle_call tr' id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr)) < + Int64.modulus) + k_c id f stmt k0 e le m_c + (MS0 : match_genv ge_i ge_c) + (MS1 : match_mem ge_i k_c m_i m_c) + (MS2 : match_cur_fun ge_i ge_c cur f id) + (MS4 : match_cont ge_c (pretr ++ (id_cur, Bundle_call tr' id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr) cnts k0 k_i) + (MS3 : match_find_def ge_i ge_c cnts pars (pretr ++ (id_cur, Bundle_call tr' id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr)) + (MS5 : match_params pars ge_c ge_i) + (MCNTS : match_cnts cnts ge_c k_c) + (CNT_INJ : forall (id0 id1 : positive) (cnt : ident), + cnts ! id0 = Some cnt -> cnts ! id1 = Some cnt -> id0 = id1) + (WFC0 : forall (id : ident) (b : block) gd, + Genv.find_symbol ge_i id = Some b -> + Genv.find_def ge_i b = Some gd -> + exists cnt : ident, + cnts ! id = Some cnt /\ + wf_counter ge_c m_c (comp_of gd) (Datatypes.length (get_id_tr pretr id)) cnt) + m_freeenv + (FREEENV : Mem.free_list m_c (blocks_of_env ge_c e) (comp_of f) = Some m_freeenv) + (WFC1 : wf_c_cont ge_c m_freeenv k0) + (WFC2 : wf_c_stmt ge_c (comp_of f) cnts id + (pretr ++ (id_cur, Bundle_call tr' id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr) stmt) + (WFC3 : wf_env ge_c e) + (WFC4 : not_global_blks ge_c (blocks_of_env2 ge_c e)) + (WFNB : wf_c_nb ge_c m_c) + b + (FINDB : Genv.find_symbol ge_i id0 = Some b) + (FINDF : Genv.find_funct ge_i (Vptr b Ptrofs.zero) = Some (AST.External ef)) + (NPTR : crossing_comp ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) (comp_of ef) -> + Forall not_ptr vargs) + (ALLOW : Genv.allowed_call ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) + (Vptr b Ptrofs.zero)) + (m1' m2 : mem) + (vretv : val) + (DELTA : mem_delta_apply_wf ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) d (Some m_i) = Some m1') + (TR1 : call_trace_cross ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) + (comp_of ef) b vargs (sig_args (ef_sig ef)) tr1 id0 (vals_to_eventvals ge_i vargs)) + (TR2 : external_call ef ge_i vargs m1' tr2 vretv m2) + (ECCASES : external_call_unknowns ef ge_i m1' vargs \/ + external_call_known_observables ef ge_i m1' vargs tr2 vretv m2 /\ d = []) + (IDCUR : Genv.invert_symbol ge_i cur = Some id_cur) + (TR_APP: exists tr0, tr' = tr1 ++ tr2 ++ tr0) + : + exists cnt_cur cnt_cur_b, + (cnts ! id_cur = Some cnt_cur /\ Senv.find_symbol ge_c cnt_cur = Some cnt_cur_b /\ Senv.public_symbol ge_c cnt_cur = false) /\ + let dsg := from_sig_fun_data (ef_sig ef) in + exists m_c', + (exists vres m_next, + (star step1 ge_c (State f stmt k0 e le m_c) + (tr1 ++ tr2) + (Returnstate vres (Kcall None f e le (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_cur (comp_of f) (get_id_tr (pretr ++ (id_cur, Bundle_call tr' id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr) id_cur))) Sskip k0)) m_next (rettype_of_type (dret dsg)) (comp_of ef))) /\ + (external_call ef ge_c vargs m_c' tr2 vres m_next)) + /\ + (exists m_cu, + (Mem.storev Mint64 m_c (Vptr cnt_cur_b Ptrofs.zero) (Vlong (Int64.add (nat64 (Datatypes.length (map (fun ib : ident * bundle_event => code_bundle_event ge_i (comp_of f) (snd ib)) (get_id_tr pretr id_cur)))) Int64.one)) (comp_of f) = Some m_cu) /\ + (d = [] -> m_c' = m_cu) /\ + ((public_first_order ge_i m1') -> + (mem_delta_apply_wf ge_i (comp_of f) d (Some m_cu) = Some m_c') /\ + (Mem.inject (meminj_public ge_i) m1' m_c'))) + . + Proof. + hexploit ir_to_clight_step_cce_1; eauto. + { desH ECCASES; [left | right; auto]. apply external_call_unknowns_fo in ECCASES. + apply meminj_first_order_public_first_order; auto. + } + { desH TR_APP. eauto. } + instantiate (1:=le). + intros (cnt_cur & cnt_cur_b & (CNT_CUR & FIND_CNT & CNT_CUR_NP) & m_c' & STAR & MEM). + destruct MEM as (m_cu & CNT_CUR_STORE & DELTA_NIL & DELTA_PUB). + exists cnt_cur, cnt_cur_b. split; auto. ss. exists m_c'. split. + 2:{ exists m_cu. splits; auto. } + desH ECCASES; cycle 1. + + (* Case 1: observable defined external calls *) + { clear DELTA_PUB. subst d. specialize (DELTA_NIL eq_refl). subst m_c'. + unfold mem_delta_apply_wf in DELTA. simpl in DELTA. inversion DELTA; clear DELTA. subst m1'. + hexploit exists_vargs_vres. eapply MS0. eapply ECCASES. eauto. intros (EVALS & EXT2). + esplits. 2: eapply EXT2. + eapply star_trans. eapply STAR. + { econs 2. eapply step_external_function. eapply EXT2. econs 1. ss. } + { traceEq. } + } + + (* Case 2: observable defined external calls *) + { clear DELTA_NIL. + hexploit external_call_unknowns_fo. eapply ECCASES. intros FO_I. + hexploit external_call_unknowns_val_inject_list. eapply ECCASES. intros ARGS_INJ. + hexploit meminj_first_order_public_first_order. apply FO_I. intros PFO. + specialize (DELTA_PUB PFO). desH DELTA_PUB. + move MS1 after ARGS_INJ. destruct MS1 as (MM0 & MM1 & MM2). + hexploit external_call_mem_inject_gen. + { eapply match_symbs_symbols_inject. apply MS0. } + apply TR2. apply DELTA_PUB0. apply ARGS_INJ. + intros (j2 & vres2 & m_next & EC2 & RET_INJ & INJ2 & UCH0 & UCH1 & INCR2 & INJ_SEP). + exists vres2, m_next. split; [|auto]. eapply star_trans. eapply STAR. + { econs 2. eapply step_external_function. eapply EC2. econs 1. ss. } + traceEq. + Unshelve. exact 1%positive. exact le. + } + Qed. + + Lemma val_inject_not_ptr + k v1 v2 + (VI: Val.inject k v1 v2) + (NPTR: not_ptr v1) + : + not_ptr v2. + Proof. inv VI; auto. ss. Qed. + + Lemma not_ptr_val_inject_eq + j v1 v2 + (VI: Val.inject j v1 v2) + (NPTR: not_ptr v1) + : + v1 = v2. + Proof. inv VI; ss. Qed. + + Lemma ir_to_clight_step_1 + ge_i ge_c + (WFGE : wf_ge ge_i) + cnts pars k_i cur m_i + pretr btr + tr id0 evargs f_next d id_cur + (BOUND : Z.of_nat + (Datatypes.length + (pretr ++ (id_cur, Bundle_call tr id0 evargs (fn_sig f_next) d) :: btr)) < + Int64.modulus) + k_c id f stmt k0 e le m_c + (MS0 : match_genv ge_i ge_c) + (MS1 : match_mem ge_i k_c m_i m_c) + (MS2 : match_cur_fun ge_i ge_c cur f id) + (MS4 : match_cont ge_c (pretr ++ (id_cur, Bundle_call tr id0 evargs (fn_sig f_next) d) :: btr) + cnts k0 k_i) + (MS3 : match_find_def ge_i ge_c cnts pars + (pretr ++ (id_cur, Bundle_call tr id0 evargs (fn_sig f_next) d) :: btr)) + (MS5 : match_params pars ge_c ge_i) + (MCNTS : match_cnts cnts ge_c k_c) + (CNT_INJ : forall (id0 id1 : positive) (cnt : ident), + cnts ! id0 = Some cnt -> cnts ! id1 = Some cnt -> id0 = id1) + (WFC0 : forall (id : ident) (b : block) gd, + Genv.find_symbol ge_i id = Some b -> + Genv.find_def ge_i b = Some gd -> + exists cnt : ident, + cnts ! id = Some cnt /\ + wf_counter ge_c m_c (comp_of gd) (Datatypes.length (get_id_tr pretr id)) cnt) + m_freeenv + (FREEENV : Mem.free_list m_c (blocks_of_env ge_c e) (comp_of f) = Some m_freeenv) + (WFC1 : wf_c_cont ge_c m_freeenv k0) + (WFC2 : wf_c_stmt ge_c (comp_of f) cnts id + (pretr ++ (id_cur, Bundle_call tr id0 evargs (fn_sig f_next) d) :: btr) stmt) + (WFC3 : wf_env ge_c e) + (WFC4 : not_global_blks ge_c (blocks_of_env2 ge_c e)) + (WFNB : wf_c_nb ge_c m_c) + vargs b m2 + (FINDB : Genv.find_symbol ge_i id0 = Some b) + (FINDF : Genv.find_funct ge_i (Vptr b Ptrofs.zero) = Some (AST.Internal f_next)) + (NPTR : crossing_comp ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) (comp_of f_next) -> + Forall not_ptr vargs) + (ALLOW : Genv.allowed_call ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) + (Vptr b Ptrofs.zero)) + (DELTA : mem_delta_apply_wf ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) d (Some m_i) = + Some m2) + (TR : call_trace_cross ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) + (comp_of f_next) b vargs (sig_args (fn_sig f_next)) tr id0 evargs) + (PUB : public_first_order ge_i m2) + (IDCUR : Genv.invert_symbol ge_i cur = Some id_cur) + : + exists cst2 : state, + star step1 ge_c (State f stmt k0 e le m_c) + (unbundle (id_cur, Bundle_call tr id0 evargs (fn_sig f_next) d)) cst2 /\ + ((exists id' : positive, + wf_c_state ge_i ge_c (pretr ++ [(id_cur, Bundle_call tr id0 evargs (fn_sig f_next) d)]) + (pretr ++ (id_cur, Bundle_call tr id0 evargs (fn_sig f_next) d) :: btr) cnts id' cst2 /\ + (exists k : meminj, + match_state ge_i ge_c k + (pretr ++ (id_cur, Bundle_call tr id0 evargs (fn_sig f_next) d) :: btr) cnts pars + id' (Some (b, m2, ir_cont cur :: k_i)) cst2)) \/ + Some (b, m2, ir_cont cur :: k_i) = None). + Proof. + assert (id = id_cur). + { unfold match_cur_fun in MS2. des. rewrite MS7 in IDCUR. clarify. } + subst id. + rename f_next into fi_next. + + exploit MS3. + { eapply Genv.find_funct_ptr_iff. erewrite <- Genv.find_funct_find_funct_ptr. eapply FINDF. } + { eapply Genv.find_invert_symbol; eauto. } + intros FINDF_C. des_ifs. rename id0 into id_next, i into cnt_next, Heq into CNTS_NEXT, l into params_next, Heq0 into PARS_NEXT. simpl in FINDF_C. + set (pretr ++ (id_cur, Bundle_call tr id_next evargs (fn_sig fi_next) d) :: btr) as ttr in *. + set (gen_function ge_i cnt_next params_next (get_id_tr ttr id_next) fi_next) as f_next in *. + set (fn_body f_next) as stmt_next. + hexploit Genv.invert_find_symbol. eapply IDCUR. intros FIND_CUR_I. + destruct MS2 as (FINDF_C_CUR & (f_i_cur & FINDF_I_CUR) & INV_CUR). + assert (FIND_CUR_C: Genv.find_symbol ge_c id_cur = Some cur). + { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply MSENV1 in FIND_CUR_I. auto. } + assert (FIND_FUN_C: Genv.find_funct_ptr ge_c cur = Some (Internal f)). + { auto. } + + exploit WFC0. apply FIND_CUR_I. rewrite <- Genv.find_funct_ptr_iff. apply FINDF_I_CUR. + intros (cnt_cur & CNTS_CUR & WF_CNT_CUR). + set (Kcall None f e le (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_cur (comp_of f) (get_id_tr ttr id_cur))) Sskip k0)) as kc_next. + assert (CUR_TR: get_id_tr ttr id_cur = (get_id_tr pretr id_cur) ++ (id_cur, Bundle_call tr id_next evargs (fn_sig fi_next) d) :: (get_id_tr btr id_cur)). + { subst ttr. clear. rewrite get_id_tr_app. rewrite get_id_tr_cons. ss. rewrite Pos.eqb_refl. auto. } + assert (BOUND2: Z.of_nat (Datatypes.length (map (fun ib : ident * bundle_event => code_bundle_event ge_i (comp_of f) (snd ib)) (get_id_tr ttr id_cur))) < Int64.modulus). + { rewrite map_length. eapply Z.le_lt_trans. 2: eauto. unfold get_id_tr. + apply inj_le. apply list_length_filter_le. + } + destruct WF_CNT_CUR as (CNT_CUR_NPUB & cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). + assert (PARSIGS: list_typ_to_list_type (sig_args (fn_sig fi_next)) = map snd params_next). + { destruct MS5 as (_ & WFP1 & _). exploit WFP1. apply FINDF. apply FINDB. apply PARS_NEXT. ss. } + + hexploit cur_fun_def. eapply FINDF_C_CUR. eapply FINDF_I_CUR. eapply INV_CUR. eauto. + intros (cnt_cur0 & params_cur & CNT_CUR0 & PARAMS_CUR & CUR_F). + rewrite CNTS_CUR in CNT_CUR0. inversion CNT_CUR0. subst cnt_cur0. clear CNT_CUR0. + assert (CP_CUR: (comp_of f) = (Genv.find_comp ge_i (Vptr cur Ptrofs.zero))). + { unfold Genv.find_comp. setoid_rewrite FINDF_I_CUR. subst f. ss. } + assert (COMP_CUR_EQ: comp_of (@Gfun _ unit (AST.Internal f_i_cur)) = comp_of f). + { subst f. ss. } + setoid_rewrite COMP_CUR_EQ in CNT_CUR_MEM_VA. setoid_rewrite COMP_CUR_EQ in CNT_CUR_MEM_LOAD. + + hexploit switch_spec. + { subst ttr. rewrite CUR_TR in BOUND2. rewrite map_app in BOUND2. ss. eapply BOUND2. } + { unfold wf_env in WFC3. specialize (WFC3 cnt_cur). des_ifs. eapply WFC3. } + eapply FIND_CNT_CUR. eapply CNT_CUR_MEM_VA. + { rewrite CNT_CUR_MEM_LOAD. rewrite map_length. auto. } + instantiate (1:=le). + instantiate (1:=(Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_cur (comp_of f) (get_id_tr ttr id_cur))) Sskip k0)). + instantiate (1:=Sreturn None). + intros (m_cu & CNT_CUR_STORE & CUR_SWITCH_STAR). + + assert (DELTA_C: exists m_c', (mem_delta_apply_wf ge_i (comp_of f) d (Some m_cu) = Some m_c') /\ + (Mem.inject (meminj_public ge_i) m2 m_c')). + { move MS1 after CUR_SWITCH_STAR. destruct MS1 as (MINJ & INJINCR & NALLOC). + move DELTA after NALLOC. move PUB after NALLOC. + hexploit mem_delta_apply_establish_inject_preprocess2. + apply MINJ. eapply CNT_CUR_STORE. + { instantiate (1:=ge_i). erewrite match_symbs_meminj_public. 2: destruct MS0 as (MS & _); apply MS. + ii. unfold meminj_public in H. des_ifs. apply Senv.find_invert_symbol in FIND_CNT_CUR. + rewrite FIND_CNT_CUR in Heq. clarify. + } + apply INJINCR. apply NALLOC. apply DELTA. apply PUB. + intros (m_c' & DELTA' & INJ'). exists m_c'. splits; auto. + rewrite CP_CUR. auto. + } + des. rename DELTA_C0 into MEMINJ_CNT. + assert (ENV_ALLOC: exists e_next m_c_next0, alloc_variables ge_c (comp_of f_next) empty_env m_c' (fn_params f_next ++ fn_vars f_next) e_next m_c_next0). + { eapply alloc_variables_exists. } + des. + assert (ENV_BIND: exists m_c_next, bind_parameters ge_c (comp_of f_next) e_next m_c_next0 (fn_params f_next) vargs m_c_next). + { move PARSIGS after ENV_ALLOC. inv TR; ss. + eapply bind_parameters_exists. 2: apply PARSIGS. + 2:{ eapply match_senv_eventval_list_match. 2: apply H1. destruct MS0 as (MS0 & _); auto. } + rewrite app_nil_r in ENV_ALLOC. eapply alloc_variables_forall. apply ENV_ALLOC. + { move MS5 after H1. destruct MS5. specialize (H2 _ _ PARS_NEXT). auto. } + } + des. + set (create_undef_temps (fn_temps f_next)) as le_next. + set (State f_next (fn_body f_next) + (Kcall None f e le (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_cur (comp_of f) (get_id_tr ttr id_cur))) Sskip k0)) + e_next le_next m_c_next) as cst2. + + assert (ENV_NGLOB: not_global_blks (ge_c) (blocks_of_env2 ge_c e_next)). + { clear CUR_SWITCH_STAR. move MS5 after le_next. destruct MS5 as (MP1 & MP2 & MP3). + apply Forall_forall. i. + unfold blocks_of_env2, blocks_of_env in H. rewrite map_map in H. + apply list_in_map_inv in H. des. destruct x0 as (xid & xb & xt). + apply PTree.elements_complete in H0. move WFNB after H0. + destruct (Senv.invert_symbol ge_c x) eqn:CASES; auto. exfalso. + unfold wf_c_nb in WFNB. apply Senv.invert_find_symbol in CASES. apply Senv.find_symbol_below in CASES. + hexploit alloc_variables_one_fresh_block. eapply ENV_ALLOC. + { ss. rewrite app_nil_r. eapply MP1. eauto. } + { ss. } + eapply H0. intros. apply H1; clear H1. ss. clarify. unfold Mem.valid_block. + eapply mem_delta_apply_wf_wunchanged_on in DELTA_C. eapply store_wunchanged_on in CNT_CUR_STORE. + eapply wunchanged_on_nextblock in CNT_CUR_STORE, DELTA_C. revert_until H0. clear; i. + eapply Plt_Ple_trans. eapply CASES. etransitivity. eapply WFNB. etransitivity; eauto. + Unshelve. all: exact (fun _ _ => True). + } + assert (ENV_NINJ: not_inj_blks (meminj_public ge_c) (blocks_of_env2 ge_c e_next)). + { eapply not_global_is_not_inj_bloks. auto. } + + assert (WFC_NEXT: wf_c_state ge_i ge_c (pretr ++ [(id_cur, Bundle_call tr id_next evargs (fn_sig fi_next) d)]) ttr cnts id_next cst2). + { subst cst2; ss. splits; auto. + - unfold wf_counters. splits; auto. + clear CUR_SWITCH_STAR. move WFC0 after le_next. + ii. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. + unfold wf_counter in WFC5. des. unfold wf_counter. splits; auto. + exists b1. splits; auto. + + eapply bind_parameters_valid_access. eapply ENV_BIND. + eapply alloc_variables_valid_access. eapply ENV_ALLOC. + eapply mem_delta_apply_wf_valid_access. eapply DELTA_C. + eapply Mem.store_valid_access_1. eapply CNT_CUR_STORE. + auto. + + assert (MNB: (b1 < Mem.nextblock m_c')%positive). + { eapply Mem.valid_access_implies in WFC7. + apply Mem.valid_access_valid_block in WFC7. 2: apply perm_any_N. + unfold Mem.valid_block in WFC7. + hexploit mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. intros UCH1. + hexploit store_wunchanged_on. eapply CNT_CUR_STORE. intros UCH2. + apply wunchanged_on_nextblock in UCH1, UCH2. + eapply Pos.lt_le_trans; eauto. etransitivity; eauto. + } + destruct (Pos.eq_dec id id_cur). + * subst id. clarify. ss. rewrite FIND_CNT_CUR in WFC6. clarify. + replace (comp_of gd) with + (comp_of + (gen_function ge_i cnt_cur params_cur (get_id_tr ttr id_cur) f_i_cur)). + 2:{ rewrite Genv.find_funct_ptr_iff in FINDF_I_CUR. rewrite FINDF_I_CUR in H0. + clarify. + } + erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. + 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. auto. } + erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. + 2:{ auto. } + erewrite mem_delta_apply_wf_mem_load. + 2:{ erewrite match_symbs_mem_delta_apply_wf in DELTA_C. apply DELTA_C. destruct MS0 as (MS & _). eauto. } + 2:{ eapply Genv.find_invert_symbol. eapply FIND_CNT_CUR. } + 2:{ auto. } + erewrite Mem.load_store_same. 2: eapply CNT_CUR_STORE. + ss. rewrite map_length. rewrite get_id_tr_app. ss. + rewrite Pos.eqb_refl. rewrite app_length. ss. + do 2 f_equal. apply nat64_int64_add_one. + subst ttr. clear - BOUND. unfold get_id_tr. eapply Z.le_lt_trans; eauto. + eapply inj_le. rewrite app_length. etransitivity. eapply list_length_filter_le. + apply Nat.le_add_r. + * ss. erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. + 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. auto. } + erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. + 2:{ auto. } + erewrite mem_delta_apply_wf_mem_load. + 2:{ erewrite match_symbs_mem_delta_apply_wf in DELTA_C. apply DELTA_C. destruct MS0 as (MS & _). eauto. } + 2:{ eapply Genv.find_invert_symbol. eapply WFC6. } + 2:{ auto. } + erewrite Mem.load_store_other. 2: eapply CNT_CUR_STORE. + 2:{ left. ii. clarify. apply Genv.find_invert_symbol in FIND_CNT_CUR, WFC6. + rewrite FIND_CNT_CUR in WFC6. clarify. rename cnt into cnt_cur. + specialize (CNT_INJ _ _ _ CNTS_CUR WFC0). clarify. + } + rewrite get_id_tr_app. ss. apply Pos.eqb_neq in n. rewrite n. rewrite app_nil_r. + rewrite WFC8. auto. + + - clear CUR_SWITCH_STAR. move WFC1 after le_next. move WFC4 after WFC1. move FREEENV after WFC4. + hexploit alloc_variables_exists_free_list. eapply ENV_ALLOC. ss. ss. ss. intros; des. + hexploit wunchanged_on_exists_mem_free_list. 2: eapply H. + { eapply wunchanged_on_implies. eapply bind_parameters_wunchanged_on. apply ENV_BIND. ss. } + intros (m_f' & FREE). + assert (WU: wunchanged_on (fun b _ => Mem.valid_block m_c b) m_c m_f'). + { eapply wunchanged_on_trans. eapply store_wunchanged_on. eapply CNT_CUR_STORE. + eapply wunchanged_on_trans. eapply wunchanged_on_implies. eapply mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. ss. + eapply wunchanged_on_trans. eapply wunchanged_on_implies. eapply alloc_variables_wunchanged_on. eapply ENV_ALLOC. ss. + eapply wunchanged_on_trans. eapply wunchanged_on_implies. eapply bind_parameters_wunchanged_on. eapply ENV_BIND. ss. + eapply mem_free_list_wunchanged_on. eapply FREE. + eapply alloc_variables_fresh_blocks. eapply ENV_ALLOC. + 2:{ unfold blocks_of_env, empty_env. ss. } + hexploit mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. i. eapply wunchanged_on_nextblock in H0. + etransitivity. 2: eapply H0. erewrite <- Mem.nextblock_store. 2: eapply CNT_CUR_STORE. lia. + } + hexploit wunchanged_on_exists_mem_free_list. eapply WU. eapply FREEENV. intros (m_freeenv' & FREEENV'). + exists m_f'. splits; auto. econs. 1,2,3: eauto. eapply FREEENV'. + hexploit wunchanged_on_free_list_preserves. eapply WU. eapply FREEENV. eapply FREEENV'. intros WUFREE. + move WFC1 after FREEENV'. + eapply wf_c_cont_wunchanged_on. eapply WFC1. apply WUFREE. + + - move WFC2 after le_next. unfold wf_c_stmt in *. clear CUR_SWITCH_STAR. + i. rewrite CNTS_NEXT in H. inv H. rename cnt into cnt_next. + subst f_next. unfold comp_of. ss. apply match_symbs_code_bundle_trace. + destruct MS0 as (MS0 & _); auto. + + - clear CUR_SWITCH_STAR. move MS5 after le_next. destruct MS5 as (MP1 & MP2 & MP3). + eapply alloc_variables_wf_params_of_symb. eapply ENV_ALLOC. eapply MP3. + rewrite app_nil_r. apply PARS_NEXT. + + - clear CUR_SWITCH_STAR. move WFNB after ENV_NINJ. unfold wf_c_nb in *. + eapply bind_parameters_wunchanged_on in ENV_BIND. eapply alloc_variables_wunchanged_on in ENV_ALLOC. + eapply mem_delta_apply_wf_wunchanged_on in DELTA_C. eapply store_wunchanged_on in CNT_CUR_STORE. + eapply wunchanged_on_nextblock in CNT_CUR_STORE, DELTA_C, ENV_ALLOC, ENV_BIND. + clear - CNT_CUR_STORE DELTA_C ENV_ALLOC ENV_BIND WFNB. + do 5 (etransitivity; eauto). + } + + assert (MS_NEXT: match_state ge_i ge_c (meminj_public ge_i) ttr cnts pars id_next (Some (b, m2, ir_cont cur :: k_i)) cst2). + { clear CUR_SWITCH_STAR WFC_NEXT. subst cst2. ss. + rewrite app_nil_r in ENV_ALLOC. splits; auto. + - unfold match_mem. splits; auto. + + eapply bind_parameters_outside_mem_inject. eapply ENV_BIND. + 2:{ eapply not_inj_blks_get_env. erewrite match_symbs_meminj_public. eapply ENV_NINJ. destruct MS0 as (MS0 & _). apply MS0. + } + 2: apply meminj_public_same_block. + eapply alloc_variables_mem_inject. eapply ENV_ALLOC. auto. + + move MS1 after ENV_NINJ. destruct MS1 as (MM1 & MM2 & MM3). + move DELTA after ENV_NINJ. eapply meminj_not_alloc_delta. eapply MM3. eapply DELTA. + - unfold match_cur_fun. splits; auto. + + rewrite Genv.find_funct_ptr_iff. eapply FINDF_C. + + eexists. eapply FINDF. + + apply Genv.find_invert_symbol. apply FINDB. + - move MS4 after ENV_NINJ. econs 2. 4,5,6: eauto. all: auto. + apply Genv.find_invert_symbol. apply FIND_CUR_C. + - move MS1 after ENV_NINJ. move MCNTS after MS1. destruct MS1 as (MM1 & MM2 & MM3). + eapply mem_inject_incr_match_cnts_rev. eapply MM2. auto. + } + + exists cst2. split. + 2:{ left. exists id_next. split. apply WFC_NEXT. eexists. eapply MS_NEXT. } + unfold wf_c_stmt in WFC2. specialize (WFC2 _ CNTS_CUR). subst stmt. + eapply star_trans. eapply code_bundle_trace_spec. 2: ss. + unfold switch_bundle_events at 1. rewrite CUR_TR at 1. rewrite map_app. simpl. + rewrite ! (match_symbs_code_bundle_call ge_i ge_c) in CUR_SWITCH_STAR. rewrite ! (match_symbs_code_bundle_events ge_i ge_c) in CUR_SWITCH_STAR. + eapply star_trans. eapply CUR_SWITCH_STAR. 2: ss. 2,3: auto. + clear BOUND2 CUR_SWITCH_STAR. + unfold code_bundle_call. eapply star_trans. eapply code_mem_delta_correct. auto. + { erewrite <- match_symbs_mem_delta_apply_wf. eapply DELTA_C. + destruct MS0 as (MSYMB & _). auto. } + 2: ss. 2,3: destruct MS0 as (MSENV & _); apply MSENV. + unfold unbundle. simpl. rename b into next. + + assert (CP_NEXT: + (Genv.find_comp ge_c (Vptr next Ptrofs.zero)) = + (comp_of fi_next)). + { unfold Genv.find_comp. apply Genv.find_funct_ptr_iff in FINDF_C. setoid_rewrite FINDF_C. subst f_next. ss. } + assert (EVARGS: list_eventval_to_list_val ge_c evargs = vargs). + { destruct MS0 as (MSENV & MGENV). inv TR. + eapply eventval_list_match_list_eventval_to_list_val. eapply match_symbs_eventval_list_match; eauto. + } + + econs 2. + { eapply step_call. ss. + { econs. assert (FSN_C: Senv.find_symbol ge_c id_next = Some next). + { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply MSENV1. auto. } + eapply eval_Evar_global. + - unfold wf_env in WFC3. specialize (WFC3 id_next). rewrite FSN_C in WFC3. apply WFC3. + - eapply FSN_C. + - econs 2. ss. + } + { eapply list_eventval_to_expr_val_eval. auto. inv TR. eapply eventval_list_match_transl. eapply match_senv_eventval_list_match; eauto. destruct MS0 as (MSENV & _); auto. } + { unfold match_find_def in MS3. hexploit MS3. + unfold Genv.find_funct in FINDF. rewrite pred_dec_true in FINDF; auto. unfold Genv.find_funct_ptr in FINDF. des_ifs. eapply Heq. + eapply Senv.find_invert_symbol; eapply FINDB. + rewrite CNTS_NEXT, PARS_NEXT. intros. unfold Genv.find_funct. rewrite pred_dec_true. unfold Genv.find_funct_ptr. rewrite H. ss. ss. + } + { ss. unfold type_of_function, gen_function. ss. f_equal. apply type_of_params_eq. apply PARSIGS. } + { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). + subst f. setoid_rewrite CP_CUR. + eapply allowed_call_gen_function; eauto. + { setoid_rewrite Genv.find_funct_ptr_iff. rewrite FINDF_C. subst f_next. eauto. } + } + { move NPTR after MS_NEXT. move TR after NPTR. i. + rewrite EVARGS. apply NPTR. unfold crossing_comp. rewrite <- H. + setoid_rewrite CP_CUR. rewrite CP_NEXT. auto. + } + { move TR after MS_NEXT. instantiate (1:=tr). inv TR. + setoid_rewrite CP_CUR. rewrite CP_NEXT. + econs 2. + { rewrite <- H. ss. } + eauto. + { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply Genv.find_invert_symbol. apply MSENV1. auto. } + { eapply eventval_list_match_transl. eapply match_senv_eventval_list_match; eauto. destruct MS0 as (MSENV & _); auto. } + } + } + { econs 2. 2: econs 1. eapply step_internal_function. 2: ss. + econs; eauto. + { destruct MS5 as (MPARS & _). specialize (MPARS _ _ PARS_NEXT). subst f_next. ss. rewrite app_nil_r. auto. } + { rewrite EVARGS. auto. } + } + traceEq. + + Unshelve. all: try exact 0%nat. all: exact (fun _ _ => True). + Qed. + + Lemma ir_to_clight_step_2 + ge_i ge_c + (WFGE : wf_ge ge_i) + cnts pars cur m_i pretr btr tr evretv d id_cur + (BOUND : Z.of_nat (Datatypes.length (pretr ++ (id_cur, Bundle_return tr evretv d) :: btr)) < + Int64.modulus) + k_c id f stmt k0 e le m_c + (MS0 : match_genv ge_i ge_c) + (MS1 : match_mem ge_i k_c m_i m_c) + (MS2 : match_cur_fun ge_i ge_c cur f id) + (MS3 : match_find_def ge_i ge_c cnts pars (pretr ++ (id_cur, Bundle_return tr evretv d) :: btr)) + next ik_tl + (MS4 : match_cont ge_c (pretr ++ (id_cur, Bundle_return tr evretv d) :: btr) cnts k0 + (ir_cont next :: ik_tl)) + (MS5 : match_params pars ge_c ge_i) + (MCNTS : match_cnts cnts ge_c k_c) + (CNT_INJ : forall (id0 id1 : positive) (cnt : ident), + cnts ! id0 = Some cnt -> cnts ! id1 = Some cnt -> id0 = id1) + (WFC0 : forall (id : ident) (b : block) gd, + Genv.find_symbol ge_i id = Some b -> + Genv.find_def ge_i b = Some gd -> + exists cnt : ident, + cnts ! id = Some cnt /\ + wf_counter ge_c m_c (comp_of gd) (Datatypes.length (get_id_tr pretr id)) cnt) + m_freeenv + (FREEENV : Mem.free_list m_c (blocks_of_env ge_c e) (comp_of f) = Some m_freeenv) + (WFC1 : wf_c_cont ge_c m_freeenv k0) + (WFC2 : wf_c_stmt ge_c (comp_of f) cnts id (pretr ++ (id_cur, Bundle_return tr evretv d) :: btr) + stmt) + (WFC3 : wf_env ge_c e) + (WFC4 : not_global_blks ge_c (blocks_of_env2 ge_c e)) + (WFNB : wf_c_nb ge_c m_c) + vretv fd_cur f_next m2 + (FINDFD : Genv.find_funct_ptr ge_i cur = Some fd_cur) + (NPTR : crossing_comp ge_i (Genv.find_comp ge_i (Vptr next Ptrofs.zero)) + (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) -> not_ptr vretv) + (INTERNAL : Genv.find_funct_ptr ge_i next = Some (AST.Internal f_next)) + (TR : return_trace_cross ge_i (Genv.find_comp ge_i (Vptr next Ptrofs.zero)) + (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) vretv (sig_res (funsig fd_cur)) tr evretv) + (DELTA : mem_delta_apply_wf ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) d (Some m_i) = + Some m2) + (PUB : public_first_order ge_i m2) + (IDCUR : Genv.invert_symbol ge_i cur = Some id_cur) + : + exists cst2 : state, + star step1 ge_c (State f stmt k0 e le m_c) (unbundle (id_cur, Bundle_return tr evretv d)) + cst2 /\ + ((exists id' : positive, + wf_c_state ge_i ge_c (pretr ++ [(id_cur, Bundle_return tr evretv d)]) + (pretr ++ (id_cur, Bundle_return tr evretv d) :: btr) cnts id' cst2 /\ + (exists k : meminj, + match_state ge_i ge_c k (pretr ++ (id_cur, Bundle_return tr evretv d) :: btr) cnts + pars id' (Some (next, m2, ik_tl)) cst2)) \/ Some (next, m2, ik_tl) = None). + Proof. + assert (id = id_cur). + { unfold match_cur_fun in MS2. des. rewrite MS7 in IDCUR. clarify. } + subst id. rename f_next into fi_next. + assert (INV_ID_NEXT: exists id_next, Genv.invert_symbol ge_i next = Some id_next). + { rewrite Genv.find_funct_ptr_iff in INTERNAL. eapply wf_ge_block_to_id. auto. eauto. } + des. + destruct MS2 as (FINDF_C_CUR & (f_i_cur & FINDF_I_CUR) & INV_CUR). + assert (FIND_CUR_I: Genv.find_symbol ge_i id_cur = Some cur). + { apply Genv.invert_find_symbol; auto. } + + exploit MS3. + { eapply Genv.find_funct_ptr_iff. eapply INTERNAL. } + { eapply INV_ID_NEXT. } + intros FINDF_C. des_ifs. rename i into cnt_next, Heq into CNTS_NEXT, l into params_next, Heq0 into PARS_NEXT. simpl in FINDF_C. + set (pretr ++ (id_cur, Bundle_return tr evretv d) :: btr) as ttr in *. + set (gen_function ge_i cnt_next params_next (get_id_tr ttr id_next) fi_next) as f_next in *. + set (fn_body f_next) as stmt_next. + assert (FIND_CUR_C: Genv.find_symbol ge_c id_cur = Some cur). + { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply Genv.invert_find_symbol in IDCUR. apply MSENV1 in IDCUR. auto. } + assert (FIND_FUN_C: Genv.find_funct_ptr ge_c cur = Some (Internal f)). + { auto. } + + exploit WFC0. eapply FIND_CUR_I. rewrite <- Genv.find_funct_ptr_iff; eauto. + intros (cnt_cur & CNTS_CUR & WF_CNT_CUR). + inv WFC1. + { inv MS4. inv IK. inv CK. } + assert (CUR_TR: get_id_tr ttr id_cur = (get_id_tr pretr id_cur) ++ (id_cur, Bundle_return tr evretv d) :: (get_id_tr btr id_cur)). + { subst ttr. clear. rewrite get_id_tr_app. rewrite get_id_tr_cons. ss. rewrite Pos.eqb_refl. auto. } + assert (BOUND2: Z.of_nat (Datatypes.length (map (fun ib : ident * bundle_event => code_bundle_event ge_i (comp_of f) (snd ib)) (get_id_tr ttr id_cur))) < Int64.modulus). + { rewrite map_length. eapply Z.le_lt_trans. 2: eauto. unfold get_id_tr. + apply inj_le. apply list_length_filter_le. + } + destruct WF_CNT_CUR as (CNT_CUR_NPUB & cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). + assert (PARSIGS: list_typ_to_list_type (sig_args (fn_sig fi_next)) = map snd params_next). + { destruct MS5 as (_ & WFP1 & _). exploit WFP1. apply INTERNAL. apply Genv.invert_find_symbol. apply INV_ID_NEXT. apply PARS_NEXT. ss. } + + inv MS4. + { inv IK. } + clarify. + + hexploit cur_fun_def. eapply FIND_FUN_C. eapply FINDFD. eapply IDCUR. eauto. + intros (cnt_cur0 & params_cur & CNT_CUR0 & PARAMS_CUR & CUR_F). + rewrite CNTS_CUR in CNT_CUR0. inversion CNT_CUR0. subst cnt_cur0. clear CNT_CUR0. + assert (CP_CUR: (comp_of f) = (Genv.find_comp ge_i (Vptr cur Ptrofs.zero))). + { unfold Genv.find_comp. setoid_rewrite FINDFD. subst f. ss. } + assert (COMP_CUR_EQ: comp_of (@Gfun _ unit (AST.Internal f_i_cur)) = comp_of f). + { subst f. ss. } + setoid_rewrite COMP_CUR_EQ in CNT_CUR_MEM_VA. setoid_rewrite COMP_CUR_EQ in CNT_CUR_MEM_LOAD. + + rename ck'0 into ck_next. rename e1 into e_next. rename le1 into le_next. + hexploit switch_spec. + { subst ttr. rewrite CUR_TR in BOUND2. rewrite map_app in BOUND2. ss. eapply BOUND2. } + { unfold wf_env in WFC3. specialize (WFC3 cnt_cur). des_ifs. eapply WFC3. } + eapply FIND_CNT_CUR. eapply CNT_CUR_MEM_VA. + { rewrite CNT_CUR_MEM_LOAD. rewrite map_length. auto. } + instantiate (1:=le). + instantiate (1:= (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_cur (comp_of f) (get_id_tr ttr id_cur))) + Sskip + (Kcall None f_next e_next le_next (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_next (comp_of f_next) (get_id_tr ttr id_next))) Sskip ck_next)))). + instantiate (1:=Sreturn None). + intros (m_cu & CNT_CUR_STORE & CUR_SWITCH_STAR). + + assert (DELTA_C: exists m_c', (mem_delta_apply_wf ge_i (comp_of f) d (Some m_cu) = Some m_c') /\ + (Mem.inject (meminj_public ge_i) m2 m_c')). + { move MS1 after CUR_SWITCH_STAR. destruct MS1 as (MINJ & INJINCR & NALLOC). + move DELTA after NALLOC. move PUB after NALLOC. + hexploit mem_delta_apply_establish_inject_preprocess2. + apply MINJ. eapply CNT_CUR_STORE. + { instantiate (1:=ge_i). erewrite match_symbs_meminj_public. 2: destruct MS0 as (MS & _); apply MS. + ii. unfold meminj_public in H. des_ifs. apply Senv.find_invert_symbol in FIND_CNT_CUR. + rewrite FIND_CNT_CUR in Heq. clarify. + } + apply INJINCR. apply NALLOC. apply DELTA. apply PUB. + intros (m_c' & DELTA' & INJ'). exists m_c'. splits; auto. + rewrite CP_CUR. auto. + } + des. rename DELTA_C0 into MEMINJ_CNT. + + assert (f1 = f_next). + { rewrite <- Genv.find_funct_ptr_iff in FINDF_C. rewrite FINDF_C in FUN. clarify. } + subst f1. clear INV_CUR. + assert (id = id_next). + { apply Genv.invert_find_symbol in INV_ID_NEXT. destruct MS0 as ((_ & MS & _) & _). apply MS in INV_ID_NEXT. + apply Senv.find_invert_symbol in INV_ID_NEXT. setoid_rewrite INV_ID_NEXT in ID. clarify. + } + subst id. + assert (cnt = cnt_next). + { rewrite CNTS_NEXT in CNT. clarify. } + subst cnt. clear ID CNT. + + assert (WCHG1: wunchanged_on (fun b _ => Mem.valid_block m_c b) m_c m_c'). + { eapply wunchanged_on_trans. eapply store_wunchanged_on. eapply CNT_CUR_STORE. + eapply wunchanged_on_implies. eapply mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. ss. + } + assert (FREENEXT: exists m_c_next, Mem.free_list m_c' (blocks_of_env ge_c e) (comp_of f) = Some m_c_next). + { eapply wunchanged_on_exists_mem_free_list. eapply WCHG1. eapply FREEENV. } + des. + + set (State f_next (fn_body f_next) ck_next e_next le_next m_c_next) as cst2. + + assert (WFC_NEXT: wf_c_state ge_i ge_c (pretr ++ [(id_cur, Bundle_return tr evretv d)]) ttr cnts id_next cst2). + { clear CUR_SWITCH_STAR. ss. splits; auto. + - unfold wf_counters. split. auto. + move WFC0 after cst2. + ii. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. + unfold wf_counter in WFC1. des. unfold wf_counter. splits; auto. + exists b1. splits; auto. + + eapply mem_valid_access_wunchanged_on. eapply WFC6. + eapply wunchanged_on_trans; cycle 1. eapply mem_free_list_wunchanged_on_2. eapply FREENEXT. + eapply wunchanged_on_trans; cycle 1. eapply mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. + eapply store_wunchanged_on. eapply CNT_CUR_STORE. ss. i. + move MS5 after H0. destruct MS5 as (MP0 & MP1 & MP). specialize (MP _ _ WFC5). move WFC4 after MP. + eapply not_global_blks_global_not_in; eauto. + + move WFNB after CP_CUR. move WFC4 after WFNB. + eapply Mem.load_unchanged_on. eapply mem_free_list_unchanged_on. eapply FREENEXT. + { ss. i. eapply not_global_blks_global_not_in; eauto. } + erewrite mem_delta_apply_wf_mem_load; cycle 1. + { erewrite match_symbs_mem_delta_apply_wf in DELTA_C. apply DELTA_C. destruct MS0 as (MS & _). eauto. } + { eapply Genv.find_invert_symbol. apply WFC5. } + { auto. } + destruct (Pos.eq_dec id id_cur). + * subst id. assert (cnt_cur = cnt). + { rewrite WFC0 in CNTS_CUR. clarify. } + subst cnt. assert (b1 = cnt_cur_b). + { setoid_rewrite WFC5 in FIND_CNT_CUR. clarify. } + subst b1. assert (b0 = cur). + { rewrite FIND_CUR_I in H. clarify. } + subst b0. assert (gd = Gfun (AST.Internal f_i_cur)). + { apply Genv.find_funct_ptr_iff in FINDFD. rewrite FINDFD in H0. clarify. } + subst gd. erewrite Mem.load_store_same. + 2: setoid_rewrite COMP_CUR_EQ; eapply CNT_CUR_STORE. + ss. rewrite map_length. rewrite get_id_tr_app. ss. + rewrite Pos.eqb_refl. rewrite app_length. ss. + do 2 f_equal. apply nat64_int64_add_one. + subst ttr. clear - BOUND. unfold get_id_tr. eapply Z.le_lt_trans; eauto. + eapply inj_le. rewrite app_length. etransitivity. eapply list_length_filter_le. + apply Nat.le_add_r. + * ss. erewrite Mem.load_store_other. 2: eapply CNT_CUR_STORE. + 2:{ left. ii. clarify. apply Genv.find_invert_symbol in FIND_CNT_CUR, WFC5. + rewrite FIND_CNT_CUR in WFC5. clarify. rename cnt into cnt_cur. + specialize (CNT_INJ _ _ _ CNTS_CUR WFC0). clarify. + } + rewrite get_id_tr_app. ss. apply Pos.eqb_neq in n. rewrite n. rewrite app_nil_r. rewrite WFC7. auto. + + - move IND after cst2. move FREE after cst2. move FREEENV after cst2. + hexploit wunchanged_on_free_list_preserves. eapply WCHG1. all: eauto. intros WCHG2. + hexploit wunchanged_on_exists_mem_free_list. eapply WCHG2. eapply FREE. intros (m_c_next2 & FREE2). + exists m_c_next2. splits; auto. + hexploit wunchanged_on_free_list_preserves. eapply WCHG2. all: eauto. intros WCHG3. + eapply wf_c_cont_wunchanged_on. eapply IND. auto. + + - move WFC2 after cst2. unfold wf_c_stmt in *. i. rewrite CNTS_NEXT in H. inv H. rename cnt into cnt_next. + subst f_next. unfold comp_of. ss. apply match_symbs_code_bundle_trace. destruct MS0 as (MS0 & _); auto. + + - move WFNB after cst2. unfold wf_c_nb in *. + apply SimplLocalsproof.free_list_nextblock in FREENEXT. rewrite FREENEXT. + eapply mem_delta_apply_wf_wunchanged_on in DELTA_C. eapply store_wunchanged_on in CNT_CUR_STORE. + eapply wunchanged_on_nextblock in CNT_CUR_STORE, DELTA_C. + clear - WFNB CNT_CUR_STORE DELTA_C. + do 5 (etransitivity; eauto). + Unshelve. all: try (exact 0%nat). all: try (exact (fun _ _ => True)). + } + + assert (MS_NEXT: match_state ge_i ge_c (meminj_public ge_i) ttr cnts pars id_next (Some (b, m2, ik')) cst2). + { clear CUR_SWITCH_STAR WFC_NEXT. ss. splits; auto. + - unfold match_mem. splits; auto. + + eapply SimplLocalsproof.free_list_right_inject. eapply MEMINJ_CNT. eapply FREENEXT. + i. move WFC4 after cst2. apply not_global_is_not_inj_bloks in WFC4. setoid_rewrite Forall_forall in WFC4. + assert (b2 = b1). + { clear - H. unfold meminj_public in H. des_ifs. } + subst b2. hexploit (WFC4 b1). + { unfold blocks_of_env2, blocks_of_env in *. rewrite map_map. + eapply (in_map (fun x => fst (fst x))) in H0. ss. rewrite map_map in H0. ss. + } + intros. erewrite <- match_symbs_meminj_public in H3. rewrite H in H3. clarify. + destruct MS0 as (MS & _). apply MS. + + move MS1 after cst2. destruct MS1 as (MM1 & MM2 & MM3). + move DELTA after cst2. eapply meminj_not_alloc_delta. eapply MM3. eapply DELTA. + - unfold match_cur_fun. splits; auto. eauto. + - destruct MS1 as (MM1 & MM2 & MM3). eapply mem_inject_incr_match_cnts_rev; eauto. + } + exists cst2. split. + 2:{ left. exists id_next. split. apply WFC_NEXT. eexists. eapply MS_NEXT. } + + unfold wf_c_stmt in WFC2. specialize (WFC2 _ CNTS_CUR). subst stmt. + eapply star_trans. eapply code_bundle_trace_spec. 2: ss. + unfold switch_bundle_events at 1. rewrite CUR_TR at 1. rewrite map_app. simpl. + rewrite ! (match_symbs_code_bundle_return ge_i ge_c) in CUR_SWITCH_STAR. rewrite ! (match_symbs_code_bundle_events ge_i ge_c) in CUR_SWITCH_STAR. + eapply star_trans. eapply CUR_SWITCH_STAR. 2: ss. 2,3: destruct MS0 as (MS & _); auto. + clear BOUND2 CUR_SWITCH_STAR. + unfold code_bundle_return. eapply star_trans. eapply code_mem_delta_correct. auto. + { erewrite <- match_symbs_mem_delta_apply_wf. eapply DELTA_C. destruct MS0 as (MSYMB & _). auto. } + 2: ss. + unfold unbundle. simpl. rename b into next. + + assert (CP_NEXT: (Genv.find_comp ge_c (Vptr next Ptrofs.zero)) = (comp_of fi_next)). + { unfold Genv.find_comp. apply Genv.find_funct_ptr_iff in FINDF_C. setoid_rewrite FINDF_C. subst f_next. ss. } + assert (EVRETV: eventval_to_val ge_c evretv = vretv). + { destruct MS0 as (MSENV & MGENV). inv TR. + eapply eventval_match_eventval_to_val. eapply match_symbs_eventval_match; eauto. + } + + econs 2. + { inv TR. eapply match_senv_eventval_match in H0. 2: destruct MS0 as (MS0 & _); apply MS0. + eapply step_return_1. + - eapply eventval_to_expr_val_eval. auto. eapply H0. + - ss. + eapply sem_cast_proj_rettype. eapply H0. + - eapply FREENEXT. + } + ss. econs 2. + { assert (CPEQ1: comp_of f_next = (Genv.find_comp ge_i (Vptr next Ptrofs.zero))). + { subst f_next. unfold comp_of, gen_function. ss. unfold Genv.find_comp. setoid_rewrite INTERNAL. ss. } + assert (CPEQ2: (comp_of (gen_function ge_i cnt_cur params_cur (get_id_tr ttr id_cur) f_i_cur)) = (Genv.find_comp ge_i (Vptr cur Ptrofs.zero))). + { unfold comp_of, gen_function. ss. unfold Genv.find_comp. setoid_rewrite FINDFD. ss. } + eapply step_returnstate. + - move NPTR after EVRETV. i. rewrite EVRETV. apply NPTR. rr. rewrite CPEQ1 in H. setoid_rewrite CPEQ2 in H. apply H. + - move TR after EVRETV. instantiate (1:=tr). inv TR. setoid_rewrite CPEQ2. rewrite CPEQ1. econs; auto. + erewrite proj_rettype_to_type_rettype_of_type_eq. 2: eapply H0. + eapply match_senv_eventval_match. 2: eapply H0. apply MS0. + } + ss. econs 2. + { eapply step_skip_or_continue_loop1. auto. } + econs 2. + { eapply step_skip_loop2. } + { subst cst2. unfold code_bundle_trace. unfold Swhile. destruct MS0 as (MS0 & _). + erewrite (match_symbs_switch_bundle_events _ _ MS0). + setoid_rewrite <- CP_NEXT. unfold Genv.find_comp. setoid_rewrite FUN. + replace (comp_of (Internal f_next)) with (comp_of f_next). econs 1. ss. + } + all: traceEq. traceEq. + Qed. + + Lemma ir_to_clight_step_3 + ge_i ge_c + (WFGE : wf_ge ge_i) + cnts pars k_i cur m_i pretr btr tr id0 ef d vargs id_cur + (BOUND : Z.of_nat + (Datatypes.length + (pretr ++ + (id_cur, Bundle_call tr id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr)) < + Int64.modulus) + k_c id f stmt k0 e le m_c + (MS0 : match_genv ge_i ge_c) + (MS1 : match_mem ge_i k_c m_i m_c) + (MS2 : match_cur_fun ge_i ge_c cur f id) + (MS4 : match_cont ge_c + (pretr ++ + (id_cur, Bundle_call tr id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr) cnts + k0 k_i) + (MS3 : match_find_def ge_i ge_c cnts pars + (pretr ++ + (id_cur, Bundle_call tr id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr)) + (MS5 : match_params pars ge_c ge_i) + (MCNTS : match_cnts cnts ge_c k_c) + (CNT_INJ : forall (id0 id1 : positive) (cnt : ident), + cnts ! id0 = Some cnt -> cnts ! id1 = Some cnt -> id0 = id1) + (WFC0 : forall (id : ident) (b : block) gd, + Genv.find_symbol ge_i id = Some b -> + Genv.find_def ge_i b = Some gd -> + exists cnt : ident, + cnts ! id = Some cnt /\ + wf_counter ge_c m_c (comp_of gd) (Datatypes.length (get_id_tr pretr id)) cnt) + m_freeenv + (FREEENV : Mem.free_list m_c (blocks_of_env ge_c e) (comp_of f) = Some m_freeenv) + (WFC1 : wf_c_cont ge_c m_freeenv k0) + (WFC2 : wf_c_stmt ge_c (comp_of f) cnts id + (pretr ++ + (id_cur, Bundle_call tr id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr) + stmt) + (WFC3 : wf_env ge_c e) + (WFC4 : not_global_blks ge_c (blocks_of_env2 ge_c e)) + (WFNB : wf_c_nb ge_c m_c) + m2 b_ext m1' vretv + (FINDB : Genv.find_symbol ge_i id0 = Some b_ext) + (FINDF : Genv.find_funct ge_i (Vptr b_ext Ptrofs.zero) = Some (AST.External ef)) + (INTRA : Genv.type_of_call ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) (comp_of ef) = + Genv.InternalCall) + (MEM : mem_delta_apply_wf ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) d (Some m_i) = + Some m1') + (EC : external_call ef ge_i vargs m1' tr vretv m2) + (ECCASES : external_call_unknowns ef ge_i m1' vargs \/ + external_call_known_observables ef ge_i m1' vargs tr vretv m2 /\ d = []) + (IDCUR : Genv.invert_symbol ge_i cur = Some id_cur) + : + exists cst2 : state, + star step1 ge_c (State f stmt k0 e le m_c) + (unbundle (id_cur, Bundle_call tr id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d)) cst2 /\ + ((exists id' : positive, + wf_c_state ge_i ge_c + (pretr ++ [(id_cur, Bundle_call tr id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d)]) + (pretr ++ + (id_cur, Bundle_call tr id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr) cnts + id' cst2 /\ + (exists k : meminj, + match_state ge_i ge_c k + (pretr ++ + (id_cur, Bundle_call tr id0 (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr) + cnts pars id' (Some (cur, m2, k_i)) cst2)) \/ Some (cur, m2, k_i) = None). + Proof. + assert (id = id_cur). + { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } + subst id. rename id0 into id_next. + destruct MS2 as (FINDF_C_CUR & (f_i_cur & FINDF_I_CUR) & INV_CUR). + + set (pretr ++ (id_cur, Bundle_call tr id_next (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: btr) as ttr in *. + assert (FIND_CUR_I: Genv.find_symbol ge_i id_cur = Some cur). + { apply Genv.invert_find_symbol in IDCUR. auto. } + assert (FIND_CUR_C: Genv.find_symbol ge_c id_cur = Some cur). + { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply MSENV1 in FIND_CUR_I. auto. } + assert (FIND_FUN_C: Genv.find_funct_ptr ge_c cur = Some (Internal f)). + { auto. } + + exploit WFC0. eapply FIND_CUR_I. rewrite <- Genv.find_funct_ptr_iff; eapply FINDF_I_CUR. + intros (cnt_cur & CNTS_CUR & WF_CNT_CUR). + assert (CUR_TR: get_id_tr ttr id_cur = (get_id_tr pretr id_cur) ++ (id_cur, Bundle_call tr id_next (vals_to_eventvals ge_i vargs) (ef_sig ef) d) :: (get_id_tr btr id_cur)). + { subst ttr. clear. rewrite get_id_tr_app. rewrite get_id_tr_cons. ss. rewrite Pos.eqb_refl. auto. } + assert (BOUND2: Z.of_nat (Datatypes.length (map (fun ib : ident * bundle_event => code_bundle_event ge_i (comp_of f) (snd ib)) (get_id_tr ttr id_cur))) < Int64.modulus). + { rewrite map_length. eapply Z.le_lt_trans. 2: eauto. unfold get_id_tr. + apply inj_le. apply list_length_filter_le. + } + destruct WF_CNT_CUR as (CNT_CUR_NPUB & cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). + + hexploit cur_fun_def. eapply FINDF_C_CUR. eapply FINDF_I_CUR. eapply INV_CUR. eauto. + intros (cnt_cur0 & params_cur & CNT_CUR0 & PARAMS_CUR & CUR_F). + rewrite CNTS_CUR in CNT_CUR0. inversion CNT_CUR0. subst cnt_cur0. clear CNT_CUR0. + assert (CP_CUR: (comp_of f) = (Genv.find_comp ge_i (Vptr cur Ptrofs.zero))). + { unfold Genv.find_comp. setoid_rewrite FINDF_I_CUR. subst f. ss. } + + assert (COMP_CUR_EQ: comp_of (@Gfun _ unit (AST.Internal f_i_cur)) = comp_of f). + { subst f. ss. } + setoid_rewrite COMP_CUR_EQ in CNT_CUR_MEM_VA. setoid_rewrite COMP_CUR_EQ in CNT_CUR_MEM_LOAD. + + hexploit switch_spec. + { subst ttr. rewrite CUR_TR in BOUND2. rewrite map_app in BOUND2. ss. eapply BOUND2. } + { unfold wf_env in WFC3. specialize (WFC3 cnt_cur). des_ifs. eapply WFC3. } + eapply FIND_CNT_CUR. eapply CNT_CUR_MEM_VA. + { rewrite CNT_CUR_MEM_LOAD. rewrite map_length. auto. } + instantiate (1:=le). + instantiate (1:= (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_cur (comp_of f) (get_id_tr ttr id_cur))) Sskip k0)). + instantiate (1:=Sreturn None). + intros (m_cu & CNT_CUR_STORE & CUR_SWITCH_STAR). + rename MEM into DELTA. move ECCASES after CUR_SWITCH_STAR. + + assert (FIND_F_C: Genv.find_funct ge_c (Vptr b_ext Ptrofs.zero) = + Some (External ef (list_typ_to_typelist (sig_args (ef_sig ef))) (rettype_to_type (sig_res (ef_sig ef))) (sig_cc (ef_sig ef)))). + { unfold match_find_def in MS3. hexploit MS3. + unfold Genv.find_funct in FINDF. rewrite pred_dec_true in FINDF; auto. unfold Genv.find_funct_ptr in FINDF. des_ifs. eapply Heq. + eapply Senv.find_invert_symbol; eapply FINDB. + intros. des_ifs. ss. rewrite pred_dec_true; auto. rewrite Genv.find_funct_ptr_iff. auto. + } + assert (COMP_F_C: comp_of f = Genv.find_comp ge_c (Vptr b_ext Ptrofs.zero)). + { unfold Genv.type_of_call in INTRA. des_ifs. + setoid_rewrite CP_CUR. apply Peqb_true_eq in Heq. rewrite Heq. + unfold Genv.find_comp. setoid_rewrite FIND_F_C. ss. + } + + desH ECCASES; cycle 1. + + (* Case 3-1: observable defined external calls *) + { subst d. unfold mem_delta_apply_wf in DELTA. simpl in DELTA. inversion DELTA; clear DELTA. subst m1'. + hexploit exists_vargs_vres. eapply MS0. eapply ECCASES. eauto. intros (EVALS & EXT2). + eapply star_cut_middle. exists E0. + eexists. split. + { unfold wf_c_stmt in WFC2. specialize (WFC2 _ CNTS_CUR). subst stmt. + eapply star_trans. eapply code_bundle_trace_spec. 2: ss. + unfold switch_bundle_events at 1. rewrite CUR_TR at 1. rewrite map_app. simpl. + rewrite ! (match_symbs_code_bundle_call ge_i ge_c) in CUR_SWITCH_STAR. + rewrite ! (match_symbs_code_bundle_events ge_i ge_c) in CUR_SWITCH_STAR. + eapply star_trans. eapply CUR_SWITCH_STAR. 2: ss. 2,3: destruct MS0 as (MS & _); auto. + clear BOUND2 CUR_SWITCH_STAR. + unfold code_bundle_call. eapply star_trans. eapply code_mem_delta_correct. auto. + { unfold mem_delta_apply_wf. simpl. reflexivity. } + 2: ss. econs 2. 2: econs 1. 2: traceEq. + eapply step_call. ss. + { econs. assert (FSN_C: Senv.find_symbol ge_c id_next = Some b_ext). + { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply MSENV1. auto. } + eapply eval_Evar_global. + - unfold wf_env in WFC3. specialize (WFC3 id_next). rewrite FSN_C in WFC3. apply WFC3. + - eapply FSN_C. + - econs 2. ss. + } + { eapply EVALS. } + { eapply FIND_F_C. } + { ss. } + { left. apply COMP_F_C. } + { i. unfold Genv.type_of_call in H. rewrite <- Pos.eqb_eq in COMP_F_C. rewrite COMP_F_C in H. inv H. } + { econs 1. ii. unfold Genv.type_of_call in H. rewrite <- Pos.eqb_eq in COMP_F_C. rewrite COMP_F_C in H. inv H. } + } + clear BOUND2 CUR_SWITCH_STAR. + assert (COMP_SAME: comp_of f = comp_of ef). + { rewrite COMP_F_C. unfold Genv.find_comp. rewrite FIND_F_C. ss. } + do 2 eexists. split. + { econs 2. eapply step_external_function. eapply EXT2. + econs 2. eapply step_returnstate. + { i. exfalso. unfold Genv.type_of_call in H. rewrite <- Pos.eqb_eq in COMP_SAME. rewrite COMP_SAME in H. ss. } + { econs 1. rewrite COMP_SAME. unfold Genv.type_of_call. rewrite Pos.eqb_refl. ss. } + econs 2. eapply step_skip_or_continue_loop1. left; auto. econs 2. eapply step_skip_loop2. + econs 1. all: ss. + } + splits. + 2:{ unfold unbundle. ss. traceEq. } + + left. exists id_cur. split. + { ss. splits; auto. + - unfold wf_counters. split; auto. + move WFC0 after COMP_SAME. ii. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. + unfold wf_counter in WFC5. des. unfold wf_counter. splits; auto. + exists b0. splits; auto. + + eapply mem_valid_access_wunchanged_on. eapply WFC7. + eapply store_wunchanged_on. eapply CNT_CUR_STORE. instantiate (1:= fun _ _ => True). ss. + + destruct (Pos.eq_dec id id_cur). + * subst id. assert (cnt_cur = cnt). + { rewrite WFC0 in CNTS_CUR. clarify. } + subst cnt. assert (b0 = cnt_cur_b). + { setoid_rewrite WFC6 in FIND_CNT_CUR. clarify. } + subst b0. assert (b = cur). + { rewrite FIND_CUR_I in H. clarify. } + subst b. assert (gd = Gfun (AST.Internal f_i_cur)). + { apply Genv.find_funct_ptr_iff in FINDF_I_CUR. setoid_rewrite FINDF_I_CUR in H0. clarify. } + subst gd. + ss. erewrite Mem.load_store_same. + 2: setoid_rewrite COMP_CUR_EQ; eapply CNT_CUR_STORE. + ss. rewrite map_length. rewrite get_id_tr_app. ss. + rewrite Pos.eqb_refl. rewrite app_length. ss. + do 2 f_equal. apply nat64_int64_add_one. + subst ttr. clear - BOUND. unfold get_id_tr. eapply Z.le_lt_trans; eauto. + eapply inj_le. rewrite app_length. etransitivity. eapply list_length_filter_le. + apply Nat.le_add_r. + * ss. erewrite Mem.load_store_other. 2: eapply CNT_CUR_STORE. + 2:{ left. ii. clarify. apply Genv.find_invert_symbol in FIND_CNT_CUR, WFC6. + rewrite FIND_CNT_CUR in WFC6. clarify. rename cnt into cnt_cur. + specialize (CNT_INJ _ _ _ CNTS_CUR WFC0). clarify. + } + rewrite get_id_tr_app. ss. apply Pos.eqb_neq in n. rewrite n. rewrite app_nil_r. rewrite WFC8. auto. + - hexploit wunchanged_on_exists_mem_free_list. + { eapply store_wunchanged_on. eapply CNT_CUR_STORE. } + eapply FREEENV. intros (m_f & FREE2). esplits. eapply FREE2. + eapply wf_c_cont_wunchanged_on. eapply WFC1. + hexploit wunchanged_on_free_list_preserves. 2: eapply FREEENV. 2: eapply FREE2. 2: auto. + eapply store_wunchanged_on. eapply CNT_CUR_STORE. + - move WFC2 after COMP_SAME. unfold wf_c_stmt in *. i. rewrite CNTS_CUR in H. inv H. rename cnt into cnt_cur. ss. + - move WFNB after COMP_SAME. unfold wf_c_nb in *. erewrite Mem.nextblock_store. eapply WFNB. eapply CNT_CUR_STORE. + } + { ss. exists k_c. splits; auto. + 2:{ unfold match_cur_fun. splits; eauto. } + move MS1 after COMP_SAME. move MCNTS after COMP_SAME. destruct MS1 as (MM0 & MM1 & MM2). + assert (m2 = m_i). + { eapply known_obs_preserves_mem. eapply ECCASES. } + subst m2. unfold match_mem. splits; auto. + { eapply Mem.store_outside_inject. eapply MM0. 2: eapply CNT_CUR_STORE. ss. i. + unfold match_cnts in MCNTS. eapply MCNTS. 3: eapply H. all: eauto. + } + } + } + + (* Case 3-2: observables unknown external calls *) + { hexploit external_call_unknowns_fo. eapply ECCASES. intros FO_I. + hexploit external_call_unknowns_val_inject_list. eapply ECCASES. intros ARGS_INJ. + move MS1 after ARGS_INJ. destruct MS1 as (MM0 & MM1 & MM2). + hexploit mem_delta_apply_establish_inject_preprocess2. + eapply MM0. eapply CNT_CUR_STORE. 2: eapply MM1. 2: eapply MM2. + 2: eapply DELTA. + 2:{ apply meminj_first_order_public_first_order. auto. } + { clear CUR_SWITCH_STAR CNT_CUR_STORE. ii. erewrite match_symbs_meminj_public in H. + 2:{ destruct MS0 as (MS & _). apply MS. } + unfold meminj_public in H. des_ifs. + eapply Senv.find_invert_symbol in FIND_CNT_CUR. rewrite FIND_CNT_CUR in Heq. clarify. + } + intros (m_next0 & DELTA_C & INJ0). + hexploit external_call_mem_inject_gen. + { eapply match_symbs_symbols_inject. destruct MS0 as (MS & _). apply MS. } + apply EC. apply INJ0. apply ARGS_INJ. + intros (j2 & vres2 & m_next & EC2 & RET_INJ & INJ2 & UCH0 & UCH1 & INCR2 & INJ_SEP). + assert (COMP_SAME: comp_of f = comp_of ef). + { rewrite COMP_F_C. unfold Genv.find_comp. rewrite FIND_F_C. ss. } + + exists (State f stmt k0 e le m_next). split. + { unfold wf_c_stmt in WFC2. specialize (WFC2 _ CNTS_CUR). subst stmt. + eapply star_trans. eapply code_bundle_trace_spec. 2: ss. + unfold switch_bundle_events at 1. rewrite CUR_TR at 1. rewrite map_app. simpl. + rewrite ! (match_symbs_code_bundle_call ge_i ge_c) in CUR_SWITCH_STAR. + rewrite ! (match_symbs_code_bundle_events ge_i ge_c) in CUR_SWITCH_STAR. + eapply star_trans. eapply CUR_SWITCH_STAR. 2: ss. 2,3: destruct MS0 as (MS & _); auto. + clear BOUND2 CUR_SWITCH_STAR CNT_CUR_STORE. + unfold code_bundle_call. eapply star_trans. eapply code_mem_delta_correct. auto. + { erewrite <- match_symbs_mem_delta_apply_wf. rewrite CP_CUR. eapply DELTA_C. + destruct MS0 as (MSYMB & _). auto. + } + 2: ss. unfold unbundle. simpl. + econs 2. eapply step_call. ss. + { econs. assert (FSN_C: Senv.find_symbol ge_c id_next = Some b_ext). + { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply MSENV1. auto. } + eapply eval_Evar_global. + - unfold wf_env in WFC3. specialize (WFC3 id_next). rewrite FSN_C in WFC3. apply WFC3. + - eapply FSN_C. + - econs 2. ss. + } + { eapply match_symbs_vals_public_eval_to_vargs; auto. + destruct MS0 as (MS0 & _). auto. + eapply extcall_unkowns_vals_public; eauto. + } + { eapply FIND_F_C. } + { ss. } + { left. apply COMP_F_C. } + { i. unfold Genv.type_of_call in H. rewrite <- Pos.eqb_eq in COMP_F_C. rewrite COMP_F_C in H. inv H. } + { econs 1. ii. unfold Genv.type_of_call in H. rewrite <- Pos.eqb_eq in COMP_F_C. rewrite COMP_F_C in H. inv H. } + + econs 2. eapply step_external_function. eapply EC2. + econs 2. eapply step_returnstate. + { i. exfalso. unfold Genv.type_of_call in H. rewrite <- Pos.eqb_eq in COMP_SAME. rewrite COMP_SAME in H. ss. } + { econs 1. rewrite COMP_SAME. unfold Genv.type_of_call. rewrite Pos.eqb_refl. ss. } + econs 2. eapply step_skip_or_continue_loop1. left; auto. econs 2. eapply step_skip_loop2. + econs 1. all: ss. traceEq. + } + + clear CUR_SWITCH_STAR BOUND2. + assert (UCH2: Mem.unchanged_on (fun b _ => forall b0 ofs0, (meminj_public ge_i) b0 <> Some (b, ofs0)) m_next0 m_next). + { eapply Mem.unchanged_on_implies. eapply UCH1. ii. eapply H; eauto. } + assert (UCH3: Mem.unchanged_on (fun b _ => Senv.invert_symbol ge_c b = None) m_next0 m_next). + { eapply Mem.unchanged_on_implies. eapply UCH2. ss. i. unfold meminj_public. des_ifs. ii. clarify. + apply Senv.invert_find_symbol in Heq. destruct MS0 as ((MSE1 & MSE2 & MSE3) & _). apply MSE2 in Heq. + apply Senv.find_invert_symbol in Heq. setoid_rewrite H in Heq. ss. + } + eapply mem_unchanged_wunchanged in UCH3. + hexploit mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. intros UCH4. + hexploit wunchanged_on_trans. eapply UCH4. eapply UCH3. intros UCH5. + hexploit store_wunchanged_on. eapply CNT_CUR_STORE. intros UCH6. + hexploit wunchanged_on_trans. eapply UCH6. eapply UCH5. intros UCH7. + clear UCH3 UCH4 UCH5 UCH6. + left. exists id_cur. split. + { ss. splits; auto. + - unfold wf_counters. split; auto. + move WFC0 after COMP_SAME. ii. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. + unfold wf_counter in WFC5. des. unfold wf_counter. splits; auto. + exists b0. splits; auto. + + move MCNTS after COMP_SAME. + eapply mem_valid_access_wunchanged_on. 2: eapply mem_unchanged_wunchanged; eapply UCH2. + eapply mem_delta_apply_wf_valid_access. eapply DELTA_C. + eapply mem_valid_access_wunchanged_on. 2: eapply store_wunchanged_on; eapply CNT_CUR_STORE. + auto. instantiate (1:= fun _ _ => True). ss. + ss. i. erewrite match_symbs_meminj_public. 2: eapply MS0. eapply meminj_public_not_public_not_mapped; eauto. + + destruct (Pos.eq_dec id id_cur). + * subst id. assert (cnt_cur = cnt). + { rewrite WFC0 in CNTS_CUR. clarify. } + subst cnt. assert (b0 = cnt_cur_b). + { setoid_rewrite WFC6 in FIND_CNT_CUR. clarify. } + subst b0. assert (b = cur). + { rewrite FIND_CUR_I in H. clarify. } + subst b. assert (gd = Gfun (AST.Internal f_i_cur)). + { apply Genv.find_funct_ptr_iff in FINDF_I_CUR. setoid_rewrite FINDF_I_CUR in H0. clarify. } + subst gd. + ss. eapply Mem.load_unchanged_on. eapply UCH2. + { ss. i. erewrite match_symbs_meminj_public. 2: eapply MS0. eapply meminj_public_not_public_not_mapped; eauto. } + erewrite mem_delta_apply_wf_mem_load. + 2:{ erewrite match_symbs_mem_delta_apply_wf in DELTA_C. eapply DELTA_C. eapply MS0. } + 2:{ eapply Genv.find_invert_symbol in WFC6. eapply WFC6. } + 2:{ auto. } + erewrite Mem.load_store_same. + 2: setoid_rewrite COMP_CUR_EQ; eapply CNT_CUR_STORE. + { ss. rewrite map_length. rewrite get_id_tr_app. ss. rewrite Pos.eqb_refl. rewrite app_length. ss. + do 2 f_equal. apply nat64_int64_add_one. + subst ttr. clear - BOUND. unfold get_id_tr. eapply Z.le_lt_trans; eauto. + eapply inj_le. rewrite app_length. etransitivity. eapply list_length_filter_le. + apply Nat.le_add_r. + } + * eapply Mem.load_unchanged_on. eapply UCH2. + { ss. i. erewrite match_symbs_meminj_public. 2: eapply MS0. eapply meminj_public_not_public_not_mapped; eauto. } + erewrite mem_delta_apply_wf_mem_load. + 2:{ erewrite match_symbs_mem_delta_apply_wf in DELTA_C. eapply DELTA_C. eapply MS0. } + 2:{ eapply Genv.find_invert_symbol in WFC6. eapply WFC6. } + 2:{ auto. } + ss. erewrite Mem.load_store_other. 2: eapply CNT_CUR_STORE. + { rewrite WFC8. rewrite get_id_tr_app. ss. apply Pos.eqb_neq in n. rewrite n. rewrite app_nil_r. auto. } + { left. ii. clarify. apply Genv.find_invert_symbol in FIND_CNT_CUR, WFC6. + rewrite FIND_CNT_CUR in WFC6. clarify. rename cnt into cnt_cur. + specialize (CNT_INJ _ _ _ CNTS_CUR WFC0). clarify. + } + + - move FREEENV after COMP_SAME. move WFC1 after FREEENV. move WFC4 after FREEENV. + hexploit wunchanged_on_exists_mem_free_list_2. eapply FREEENV. + instantiate (2:=ge_c). eapply UCH7. ss. + intros (m_c' & FREE2). esplits. eapply FREE2. + eapply wf_c_cont_wunchanged_on_2. eapply WFC1. + eapply wunchanged_on_free_list_preserves_gen. 2,3: eauto. auto. + - move WFNB after UCH7. eapply wf_c_nb_wunchanged_on; eauto. + } + { ss. exists j2. splits; auto. + 2:{ unfold match_cur_fun. splits; eauto. } + { unfold match_mem. splits; auto. move DELTA after UCH7. move EC after UCH7. + eapply meminj_not_alloc_delta in MM2. 2: eapply DELTA. + eapply meminj_not_alloc_external_call. eapply MM2. eauto. + } + { ii. assert (NINJP: (meminj_public ge_i) b = None). + { move MCNTS after UCH7. specialize (MCNTS _ _ _ H H0 b ofs). + destruct (meminj_public ge_i b) eqn:CASES; ss. exfalso. + destruct p. move MM1 after UCH7. move INCR2 after UCH7. + unfold inject_incr in *. hexploit MM1. apply CASES. hexploit INCR2. apply CASES. + i. rewrite H1 in H2. clarify. + } + specialize (INJ_SEP _ _ _ NINJP H1). des. apply INJ_SEP0. + hexploit Genv.genv_symb_range. eapply H0. intros RANGE. + move WFNB before RANGE. + hexploit mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. intros T1. + hexploit store_wunchanged_on. eapply CNT_CUR_STORE. intros T2. + eapply wunchanged_on_nextblock in T1, T2. revert_until NINJP. clear. i. + unfold wf_c_nb in WFNB. unfold Mem.valid_block. eapply Plt_Ple_trans. eauto. + etransitivity. eapply WFNB. etransitivity; eauto. + } + } + } + + Unshelve. all: exact (fun _ _ => True). + Qed. + + Lemma ir_to_clight_step_4 + ge_i ge_c + (WFGE : wf_ge ge_i) + cnts pars k_i cur m_i pretr btr tr ef d vargs id_cur + (BOUND : Z.of_nat + (Datatypes.length + (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr)) < + Int64.modulus) + k_c id f stmt k0 e le m_c + (MS0 : match_genv ge_i ge_c) + (MS1 : match_mem ge_i k_c m_i m_c) + (MS2 : match_cur_fun ge_i ge_c cur f id) + (MS4 : match_cont ge_c + (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr) cnts + k0 k_i) + (MS3 : match_find_def ge_i ge_c cnts pars + (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr)) + (MS5 : match_params pars ge_c ge_i) + (MCNTS : match_cnts cnts ge_c k_c) + (CNT_INJ : forall (id0 id1 : positive) (cnt : ident), + cnts ! id0 = Some cnt -> cnts ! id1 = Some cnt -> id0 = id1) + (WFC0 : forall (id : ident) (b : block) gd, + Genv.find_symbol ge_i id = Some b -> + Genv.find_def ge_i b = Some gd -> + exists cnt : ident, + cnts ! id = Some cnt /\ + wf_counter ge_c m_c (comp_of gd) (Datatypes.length (get_id_tr pretr id)) cnt) + m_freeenv + (FREEENV : Mem.free_list m_c (blocks_of_env ge_c e) (comp_of f) = Some m_freeenv) + (WFC1 : wf_c_cont ge_c m_freeenv k0) + (WFC2 : wf_c_stmt ge_c (comp_of f) cnts id + (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr) stmt) + (WFC3 : wf_env ge_c e) + (WFC4 : not_global_blks ge_c (blocks_of_env2 ge_c e)) + (WFNB : wf_c_nb ge_c m_c) + m2 m1' vretv + (MEM : mem_delta_apply_wf ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) d (Some m_i) = + Some m1') + (ALLOWED : comp_of ef = Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) + (EC : external_call ef ge_i vargs m1' tr vretv m2) + (ECCASES : external_call_unknowns ef ge_i m1' vargs \/ + external_call_known_observables ef ge_i m1' vargs tr vretv m2 /\ d = []) + (IDCUR : Genv.invert_symbol ge_i cur = Some id_cur) + : + exists cst2 : state, + star step1 ge_c (State f stmt k0 e le m_c) + (unbundle (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d)) cst2 /\ + ((exists id' : positive, + wf_c_state ge_i ge_c + (pretr ++ [(id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d)]) + (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr) cnts + id' cst2 /\ + (exists k : meminj, + match_state ge_i ge_c k + (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr) + cnts pars id' (Some (cur, m2, k_i)) cst2)) \/ Some (cur, m2, k_i) = None). + Proof. + assert (id = id_cur). + { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } + subst id. + destruct MS2 as (FINDF_C_CUR & (f_i_cur & FINDF_I_CUR) & INV_CUR). + + set (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr) as ttr in *. + assert (FIND_CUR_I: Genv.find_symbol ge_i id_cur = Some cur). + { apply Genv.invert_find_symbol in IDCUR. auto. } + assert (FIND_CUR_C: Genv.find_symbol ge_c id_cur = Some cur). + { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply MSENV1 in FIND_CUR_I. auto. } + assert (FIND_FUN_C: Genv.find_funct_ptr ge_c cur = Some (Internal f)). + { auto. } + + exploit WFC0. eapply FIND_CUR_I. rewrite <- Genv.find_funct_ptr_iff; eapply FINDF_I_CUR. + intros (cnt_cur & CNTS_CUR & WF_CNT_CUR). + assert (CUR_TR: get_id_tr ttr id_cur = (get_id_tr pretr id_cur) ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: (get_id_tr btr id_cur)). + { subst ttr. clear. rewrite get_id_tr_app. rewrite get_id_tr_cons. ss. rewrite Pos.eqb_refl. auto. } + assert (BOUND2: Z.of_nat (Datatypes.length (map (fun ib : ident * bundle_event => code_bundle_event ge_i (comp_of f) (snd ib)) (get_id_tr ttr id_cur))) < Int64.modulus). + { rewrite map_length. eapply Z.le_lt_trans. 2: eauto. unfold get_id_tr. + apply inj_le. apply list_length_filter_le. + } + destruct WF_CNT_CUR as (CNT_CUR_NPUB & cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). + + hexploit cur_fun_def. eapply FINDF_C_CUR. eapply FINDF_I_CUR. eapply INV_CUR. eauto. + intros (cnt_cur0 & params_cur & CNT_CUR0 & PARAMS_CUR & CUR_F). + rewrite CNTS_CUR in CNT_CUR0. inversion CNT_CUR0. subst cnt_cur0. clear CNT_CUR0. + assert (CP_CUR: (comp_of f) = (Genv.find_comp ge_i (Vptr cur Ptrofs.zero))). + { unfold Genv.find_comp. setoid_rewrite FINDF_I_CUR. subst f. ss. } + assert (COMP_CUR_EQ: comp_of (@Gfun _ unit (AST.Internal f_i_cur)) = comp_of f). + { subst f. ss. } + setoid_rewrite COMP_CUR_EQ in CNT_CUR_MEM_VA. setoid_rewrite COMP_CUR_EQ in CNT_CUR_MEM_LOAD. + + hexploit switch_spec. + { subst ttr. rewrite CUR_TR in BOUND2. rewrite map_app in BOUND2. ss. eapply BOUND2. } + { unfold wf_env in WFC3. specialize (WFC3 cnt_cur). des_ifs. eapply WFC3. } + eapply FIND_CNT_CUR. eapply CNT_CUR_MEM_VA. + { rewrite CNT_CUR_MEM_LOAD. rewrite map_length. auto. } + instantiate (1:=le). + instantiate (1:= (Kloop1 (Ssequence (Sifthenelse one_expr Sskip Sbreak) (switch_bundle_events ge_c cnt_cur (comp_of f) (get_id_tr ttr id_cur))) Sskip k0)). + instantiate (1:=Sreturn None). + intros (m_cu & CNT_CUR_STORE & CUR_SWITCH_STAR). + assert (COMP_SAME: comp_of f = comp_of ef). + { rewrite ALLOWED. apply CP_CUR. } + rename MEM into DELTA. move ECCASES after CUR_SWITCH_STAR. + + desH ECCASES; cycle 1. + + (* Case 4-1: observable defined external calls *) + { subst d. unfold mem_delta_apply_wf in DELTA. simpl in DELTA. inversion DELTA; clear DELTA. subst m1'. + hexploit exists_vargs_vres_2. eapply MS0. eapply ECCASES. eauto. intros (vargs2 & vretv2 & EVALS & EXT2). + eapply star_cut_middle. exists E0. + eexists. split. + { unfold wf_c_stmt in WFC2. specialize (WFC2 _ CNTS_CUR). subst stmt. + eapply star_trans. eapply code_bundle_trace_spec. 2: ss. + unfold switch_bundle_events at 1. rewrite CUR_TR at 1. rewrite map_app. simpl. + rewrite ! (match_symbs_code_bundle_builtin ge_i ge_c) in CUR_SWITCH_STAR. + rewrite ! (match_symbs_code_bundle_events ge_i ge_c) in CUR_SWITCH_STAR. + eapply star_trans. eapply CUR_SWITCH_STAR. 2: ss. 2,3: destruct MS0 as (MS & _); auto. + clear BOUND2 CUR_SWITCH_STAR. + unfold code_bundle_builtin. eapply star_trans. eapply code_mem_delta_correct. auto. + { unfold mem_delta_apply_wf. simpl. reflexivity. } + econs 1. ss. + } + clear BOUND2 CUR_SWITCH_STAR. + do 2 eexists. split. econs 2. + { eapply step_builtin. ss. + { eapply EVALS. } + { auto. } + { eapply EXT2. } + } + econs 2. eapply step_skip_or_continue_loop1. left; auto. + econs 2. eapply step_skip_loop2. + econs 1. all: ss. + splits. + 2:{ unfold unbundle. ss. traceEq. } + + left. exists id_cur. split. + { splits; auto. + - unfold wf_counters. split; auto. + move WFC0 after COMP_SAME. ii. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. + unfold wf_counter in WFC5. des. unfold wf_counter. splits; auto. + exists b0. splits; auto. + + eapply mem_valid_access_wunchanged_on. eapply WFC7. + eapply store_wunchanged_on. eapply CNT_CUR_STORE. instantiate (1:= fun _ _ => True). ss. + + destruct (Pos.eq_dec id id_cur). + * subst id. assert (cnt_cur = cnt). + { rewrite WFC0 in CNTS_CUR. clarify. } + subst cnt. assert (b0 = cnt_cur_b). + { setoid_rewrite WFC6 in FIND_CNT_CUR. clarify. } + subst b0. assert (b = cur). + { rewrite FIND_CUR_I in H. clarify. } + subst b. assert (gd = Gfun (AST.Internal f_i_cur)). + { apply Genv.find_funct_ptr_iff in FINDF_I_CUR. setoid_rewrite FINDF_I_CUR in H0. clarify. } + subst gd. + ss. erewrite Mem.load_store_same. + 2: setoid_rewrite COMP_CUR_EQ; eapply CNT_CUR_STORE. + ss. rewrite map_length. rewrite get_id_tr_app. ss. + rewrite Pos.eqb_refl. rewrite app_length. ss. + do 2 f_equal. apply nat64_int64_add_one. + subst ttr. clear - BOUND. unfold get_id_tr. eapply Z.le_lt_trans; eauto. + eapply inj_le. rewrite app_length. etransitivity. eapply list_length_filter_le. + apply Nat.le_add_r. + * ss. erewrite Mem.load_store_other. 2: eapply CNT_CUR_STORE. + 2:{ left. ii. clarify. apply Genv.find_invert_symbol in FIND_CNT_CUR, WFC6. + rewrite FIND_CNT_CUR in WFC6. clarify. rename cnt into cnt_cur. + specialize (CNT_INJ _ _ _ CNTS_CUR WFC0). clarify. + } + rewrite get_id_tr_app. ss. apply Pos.eqb_neq in n. rewrite n. rewrite app_nil_r. rewrite WFC8. auto. + - hexploit wunchanged_on_exists_mem_free_list. + { eapply store_wunchanged_on. eapply CNT_CUR_STORE. } + eapply FREEENV. intros (m_f & FREE2). esplits. eapply FREE2. + eapply wf_c_cont_wunchanged_on. eapply WFC1. + hexploit wunchanged_on_free_list_preserves. 2: eapply FREEENV. 2: eapply FREE2. 2: auto. + eapply store_wunchanged_on. eapply CNT_CUR_STORE. + - move WFC2 after COMP_SAME. unfold wf_c_stmt in *. i. rewrite CNTS_CUR in H. inv H. rename cnt into cnt_cur. ss. + - move WFNB after COMP_SAME. unfold wf_c_nb in *. erewrite Mem.nextblock_store. eapply WFNB. eapply CNT_CUR_STORE. + } + { ss. exists k_c. splits; auto. + 2:{ unfold match_cur_fun. splits; eauto. } + move MS1 after COMP_SAME. move MCNTS after COMP_SAME. destruct MS1 as (MM0 & MM1 & MM2). + assert (m2 = m_i). + { eapply known_obs_preserves_mem. eapply ECCASES. } + subst m2. unfold match_mem. splits; auto. + { eapply Mem.store_outside_inject. eapply MM0. 2: eapply CNT_CUR_STORE. ss. i. + unfold match_cnts in MCNTS. eapply MCNTS. 3: eapply H. all: eauto. + } + } + } + + (* Case 4-2: observables unknown external calls *) + { hexploit external_call_unknowns_fo. eapply ECCASES. intros FO_I. + hexploit external_call_unknowns_val_inject_list. eapply ECCASES. intros ARGS_INJ. + move MS1 after ARGS_INJ. destruct MS1 as (MM0 & MM1 & MM2). + hexploit mem_delta_apply_establish_inject_preprocess2. + eapply MM0. eapply CNT_CUR_STORE. 2: eapply MM1. 2: eapply MM2. + 2: eapply DELTA. + 2:{ apply meminj_first_order_public_first_order. auto. } + { clear CUR_SWITCH_STAR CNT_CUR_STORE. ii. erewrite match_symbs_meminj_public in H. + 2:{ destruct MS0 as (MS & _). apply MS. } + unfold meminj_public in H. des_ifs. + eapply Senv.find_invert_symbol in FIND_CNT_CUR. rewrite FIND_CNT_CUR in Heq. clarify. + } + intros (m_next0 & DELTA_C & INJ0). + hexploit external_call_mem_inject_gen. + { eapply match_symbs_symbols_inject. destruct MS0 as (MS & _). apply MS. } + apply EC. apply INJ0. apply ARGS_INJ. + intros (j2 & vres2 & m_next & EC2 & RET_INJ & INJ2 & UCH0 & UCH1 & INCR2 & INJ_SEP). + + exists (State f stmt k0 e le m_next). split. + { unfold wf_c_stmt in WFC2. specialize (WFC2 _ CNTS_CUR). subst stmt. + eapply star_trans. eapply code_bundle_trace_spec. 2: ss. + unfold switch_bundle_events at 1. rewrite CUR_TR at 1. rewrite map_app. simpl. + rewrite ! (match_symbs_code_bundle_builtin ge_i ge_c) in CUR_SWITCH_STAR. + rewrite ! (match_symbs_code_bundle_events ge_i ge_c) in CUR_SWITCH_STAR. + eapply star_trans. eapply CUR_SWITCH_STAR. 2: ss. 2,3: destruct MS0 as (MS & _); auto. + clear BOUND2 CUR_SWITCH_STAR CNT_CUR_STORE. + unfold code_bundle_builtin. eapply star_trans. eapply code_mem_delta_correct. auto. + { erewrite <- match_symbs_mem_delta_apply_wf. rewrite CP_CUR. eapply DELTA_C. + destruct MS0 as (MSYMB & _). auto. + } + 2: ss. unfold unbundle. simpl. + econs 2. eapply step_builtin. + { eapply match_symbs_vals_public_eval_to_vargs_2; auto. + destruct MS0 as (MS0 & _). auto. eapply extcall_unkowns_vals_public; eauto. + } + { auto. } + { eapply EC2. } + econs 2. eapply step_skip_or_continue_loop1. left; auto. + econs 2. eapply step_skip_loop2. econs 1. all: ss. traceEq. + } + + clear CUR_SWITCH_STAR BOUND2. + assert (UCH2: Mem.unchanged_on (fun b _ => forall b0 ofs0, (meminj_public ge_i) b0 <> Some (b, ofs0)) m_next0 m_next). + { eapply Mem.unchanged_on_implies. eapply UCH1. ii. eapply H; eauto. } + assert (UCH3: Mem.unchanged_on (fun b _ => Senv.invert_symbol ge_c b = None) m_next0 m_next). + { eapply Mem.unchanged_on_implies. eapply UCH2. ss. i. unfold meminj_public. des_ifs. ii. clarify. + apply Senv.invert_find_symbol in Heq. destruct MS0 as ((MSE1 & MSE2 & MSE3) & _). apply MSE2 in Heq. + apply Senv.find_invert_symbol in Heq. setoid_rewrite H in Heq. ss. + } + eapply mem_unchanged_wunchanged in UCH3. + hexploit mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. intros UCH4. + hexploit wunchanged_on_trans. eapply UCH4. eapply UCH3. intros UCH5. + hexploit store_wunchanged_on. eapply CNT_CUR_STORE. intros UCH6. + hexploit wunchanged_on_trans. eapply UCH6. eapply UCH5. intros UCH7. + clear UCH3 UCH4 UCH5 UCH6. + left. exists id_cur. split. + { ss. splits; auto. + - unfold wf_counters. split; auto. + move WFC0 after COMP_SAME. ii. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. + unfold wf_counter in WFC5. des. unfold wf_counter. splits; auto. + exists b0. splits; auto. + + move MCNTS after COMP_SAME. + eapply mem_valid_access_wunchanged_on. 2: eapply mem_unchanged_wunchanged; eapply UCH2. + eapply mem_delta_apply_wf_valid_access. eapply DELTA_C. + eapply mem_valid_access_wunchanged_on. 2: eapply store_wunchanged_on; eapply CNT_CUR_STORE. + auto. instantiate (1:= fun _ _ => True). ss. + ss. i. erewrite match_symbs_meminj_public. 2: eapply MS0. eapply meminj_public_not_public_not_mapped; eauto. + + destruct (Pos.eq_dec id id_cur). + * subst id. assert (cnt_cur = cnt). + { rewrite WFC0 in CNTS_CUR. clarify. } + subst cnt. assert (b0 = cnt_cur_b). + { setoid_rewrite WFC6 in FIND_CNT_CUR. clarify. } + subst b0. assert (b = cur). + { rewrite FIND_CUR_I in H. clarify. } + subst b. assert (gd = Gfun (AST.Internal f_i_cur)). + { apply Genv.find_funct_ptr_iff in FINDF_I_CUR. setoid_rewrite FINDF_I_CUR in H0. clarify. } + subst gd. + ss. eapply Mem.load_unchanged_on. eapply UCH2. + { ss. i. erewrite match_symbs_meminj_public. 2: eapply MS0. eapply meminj_public_not_public_not_mapped; eauto. } + erewrite mem_delta_apply_wf_mem_load. + 2:{ erewrite match_symbs_mem_delta_apply_wf in DELTA_C. eapply DELTA_C. eapply MS0. } + 2:{ eapply Genv.find_invert_symbol in WFC6. eapply WFC6. } + 2:{ auto. } + erewrite Mem.load_store_same. + 2: setoid_rewrite COMP_CUR_EQ; eapply CNT_CUR_STORE. + { ss. rewrite map_length. rewrite get_id_tr_app. ss. rewrite Pos.eqb_refl. rewrite app_length. ss. + do 2 f_equal. apply nat64_int64_add_one. + subst ttr. clear - BOUND. unfold get_id_tr. eapply Z.le_lt_trans; eauto. + eapply inj_le. rewrite app_length. etransitivity. eapply list_length_filter_le. + apply Nat.le_add_r. + } + * eapply Mem.load_unchanged_on. eapply UCH2. + { ss. i. erewrite match_symbs_meminj_public. 2: eapply MS0. eapply meminj_public_not_public_not_mapped; eauto. } + erewrite mem_delta_apply_wf_mem_load. + 2:{ erewrite match_symbs_mem_delta_apply_wf in DELTA_C. eapply DELTA_C. eapply MS0. } + 2:{ eapply Genv.find_invert_symbol in WFC6. eapply WFC6. } + 2:{ auto. } + ss. erewrite Mem.load_store_other. 2: eapply CNT_CUR_STORE. + { rewrite WFC8. rewrite get_id_tr_app. ss. apply Pos.eqb_neq in n. rewrite n. rewrite app_nil_r. auto. } + { left. ii. clarify. apply Genv.find_invert_symbol in FIND_CNT_CUR, WFC6. + rewrite FIND_CNT_CUR in WFC6. clarify. rename cnt into cnt_cur. + specialize (CNT_INJ _ _ _ CNTS_CUR WFC0). clarify. + } + + - move FREEENV after COMP_SAME. move WFC1 after FREEENV. move WFC4 after FREEENV. + hexploit wunchanged_on_exists_mem_free_list_2. eapply FREEENV. + instantiate (2:=ge_c). eapply UCH7. ss. + intros (m_c' & FREE2). esplits. eapply FREE2. + eapply wf_c_cont_wunchanged_on_2. eapply WFC1. + eapply wunchanged_on_free_list_preserves_gen. 2,3: eauto. auto. + - move WFNB after UCH7. eapply wf_c_nb_wunchanged_on; eauto. + } + { ss. exists j2. splits; auto. + 2:{ unfold match_cur_fun. splits; eauto. } + { unfold match_mem. splits; auto. move DELTA after UCH7. move EC after UCH7. + eapply meminj_not_alloc_delta in MM2. 2: eapply DELTA. + eapply meminj_not_alloc_external_call. eapply MM2. eauto. + } + { ii. assert (NINJP: (meminj_public ge_i) b = None). + { move MCNTS after UCH7. specialize (MCNTS _ _ _ H H0 b ofs). + destruct (meminj_public ge_i b) eqn:CASES; ss. exfalso. + destruct p. move MM1 after UCH7. move INCR2 after UCH7. + unfold inject_incr in *. hexploit MM1. apply CASES. hexploit INCR2. apply CASES. + i. rewrite H1 in H2. clarify. + } + specialize (INJ_SEP _ _ _ NINJP H1). des. apply INJ_SEP0. + hexploit Genv.genv_symb_range. eapply H0. intros RANGE. + move WFNB before RANGE. + hexploit mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. intros T1. + hexploit store_wunchanged_on. eapply CNT_CUR_STORE. intros T2. + eapply wunchanged_on_nextblock in T1, T2. revert_until NINJP. clear. i. + unfold wf_c_nb in WFNB. unfold Mem.valid_block. eapply Plt_Ple_trans. eauto. + etransitivity. eapply WFNB. etransitivity; eauto. + } + } + } + + Unshelve. all: exact (fun _ _ => True). + Qed. + + Lemma ir_to_clight_step + (ge_i: Asm.genv) (ge_c: Clight.genv) + (WFGE: wf_ge ge_i) + cnts pars ist1 ev ist2 + (STEP: ir_step ge_i ist1 ev ist2) + ttr pretr btr + (BOUND: Z.of_nat (Datatypes.length ttr) < Int64.modulus) + (TOTAL: ttr = pretr ++ ev :: btr) + cst1 k id + (WFC: wf_c_state ge_i ge_c pretr ttr cnts id cst1) + (MS: match_state ge_i ge_c k ttr cnts pars id ist1 cst1) + : + exists cst2, (star step1 ge_c cst1 (unbundle ev) cst2) /\ + ((exists id', (wf_c_state ge_i ge_c (pretr ++ [ev]) ttr cnts id' cst2) /\ + exists k, (match_state ge_i ge_c k ttr cnts pars id' ist2 cst2)) + \/ (ist2 = None)). + Proof. + unfold wf_c_state in WFC. des_ifs. rename s into stmt, k into k_c, m into m_c. + destruct WFC as ((CNT_INJ & WFC0) & (m_freeenv & FREEENV & WFC1) & WFC2 & WFC3 & WFC4 & WFNB). + unfold match_state in MS. des_ifs. rename i into k_i, b into cur, m into m_i. + destruct MS as (MS0 & MS1 & MS2 & MS3 & MS4 & MS5 & MCNTS). + move STEP after WFC4. inv STEP. + + (** Case 1: Cross Call *) + - eapply ir_to_clight_step_1; eauto. + + (** Case 2: Cross Return *) + - eapply ir_to_clight_step_2; eauto. + + (** Case 3: Internal-External Call *) + - eapply ir_to_clight_step_3; eauto. + + (** Case 4: Builtins *) + - eapply ir_to_clight_step_4; eauto. + + (** Case 5: Cross Call External 1 *) + - hexploit ir_to_clight_step_cce_1; eauto. + { unfold mem_delta_apply_wf. ss. } + { exists []. rewrite app_nil_r. auto. } + intros (cnt_cur & cnt_cur_b & (CNT_CUR & FIND_CNT & CNT_CUR_NP) & m_c' & STAR & MEM). + destruct MEM as (m_cu & CNT_CUR_STORE & DELTA_NIL & DELTA_PUB). + eapply star_cut_middle. esplits. + { eapply STAR. } + { econs 1. } + { ss. right; auto. } + { unfold unbundle. ss. traceEq. } + + (** Case 6: Cross Call External 2 *) + - hexploit ir_to_clight_step_cce_2; eauto. + { exists []. rewrite app_nil_r. auto. } + rename MEM into DELTA. + intros (cnt_cur & cnt_cur_b & (CNT_CUR & FIND_CNT & CNT_CUR_NP) & m_c' & STAR & MEM). + destruct STAR as (vres & m_next & STAR & EC2). + destruct MEM as (m_cu & CNT_CUR_STORE & DELTA_NIL & DELTA_PUB). + eapply star_cut_middle. esplits. + { eapply STAR. } + { econs 1. } + { ss. right; auto. } + { unfold unbundle. ss. traceEq. } + + (** Case 7: Cross Call External 3 *) + - hexploit ir_to_clight_step_cce_2; eauto. + rename MEM into DELTA. + intros (cnt_cur & cnt_cur_b & (CNT_CUR & FIND_CNT & CNT_CUR_NP) & m_c' & STAR & MEM). + destruct STAR as (vres & m_next & STAR & EC2). + destruct MEM as (m_cu & CNT_CUR_STORE & DELTA_NIL & DELTA_PUB). + + assert (id = id_cur). + { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } + subst id. + assert (COMP_CUR_F: (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) = comp_of f). + { destruct MS2 as (FINDF_C_CUR & (f_i_cur & FINDF_I_CUR) & INV_CUR). + hexploit cur_fun_def. eapply FINDF_C_CUR. eapply FINDF_I_CUR. eapply INV_CUR. eauto. + intros (cnt_cur0 & params_cur & CNT_CUR0 & PARAMS_CUR & CUR_F). + unfold Genv.find_comp. setoid_rewrite FINDF_I_CUR. subst f. ss. + } + assert (FIND_CUR_I: Genv.find_symbol ge_i id_cur = Some cur). + { apply Genv.invert_find_symbol in IDCUR. auto. } + assert (FIND_CUR_C: Genv.find_symbol ge_c id_cur = Some cur). + { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply MSENV1 in FIND_CUR_I. auto. } + assert (FIND_FUN_C: Genv.find_funct_ptr ge_c cur = Some (Internal f)). + { destruct MS2 as (MFUN0 & MFUN1). auto. } + assert (COMP_CUR_EQ: (comp_of (@Gfun _ unit (AST.Internal f_cur))) = comp_of f). + { rewrite <- COMP_CUR_F. unfold Genv.find_comp. setoid_rewrite INTERNAL. ss. } + desH ECCASES; cycle 1. + + (* Case 3-1: observable defined external calls *) + { clear DELTA_PUB. subst d. specialize (DELTA_NIL eq_refl). subst m_c'. + hexploit exists_vargs_vres. apply MS0. apply ECCASES. eauto. intros (_ & EC2'). + hexploit external_call_deterministic. eapply EC2. eapply EC2'. intros (EQ1 & EQ2). + subst vres m_cu. clear EC2'. + eapply star_cut_middle. esplits. eapply STAR. + econs 2. + { eapply step_returnstate. + - i. apply NPTR0. rewrite COMP_CUR_F. apply H. + - move TR3 after COMP_CUR_F. rewrite COMP_CUR_F in TR3. instantiate (1:=tr3). + inv TR3. econs; [auto |]. ss. + erewrite proj_rettype_to_type_rettype_of_type_eq. 2: apply H0. + eapply match_symbs_eventval_match. apply MS0. auto. + } + ss. econs 2. + { eapply step_skip_or_continue_loop1. auto. } + econs 2. + { eapply step_skip_loop2. } + econs 1. all: ss. + 2:{ unfold unbundle. ss. traceEq. } + left. exists id_cur. clear STAR. split. + + - splits; auto. + { unfold wf_counters. split; auto. + move WFC0 after COMP_CUR_F. i. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. + unfold wf_counter in WFC5. des. unfold wf_counter. splits; auto. + exists b1. splits; auto. + + eapply mem_valid_access_wunchanged_on. eapply WFC7. + eapply store_wunchanged_on. eapply CNT_CUR_STORE. instantiate (1:= fun _ _ => True). ss. + + destruct (Pos.eq_dec id id_cur). + * subst id. assert (cnt_cur = cnt). + { rewrite WFC0 in CNT_CUR. clarify. } + subst cnt. assert (b1 = cnt_cur_b). + { setoid_rewrite WFC6 in FIND_CNT. clarify. } + subst b1. assert (b0 = cur). + { rewrite FIND_CUR_I in H. clarify. } + subst b0. assert (gd = Gfun (AST.Internal f_cur)). + { apply Genv.find_funct_ptr_iff in INTERNAL. setoid_rewrite INTERNAL in H0. clarify. } + subst gd. + ss. erewrite Mem.load_store_same. + 2: setoid_rewrite COMP_CUR_EQ; eapply CNT_CUR_STORE. + ss. rewrite map_length. rewrite get_id_tr_app. ss. + rewrite Pos.eqb_refl. rewrite app_length. ss. + do 2 f_equal. apply nat64_int64_add_one. + clear - BOUND. unfold get_id_tr. eapply Z.le_lt_trans; eauto. + eapply inj_le. rewrite app_length. etransitivity. eapply list_length_filter_le. + apply Nat.le_add_r. + * ss. erewrite Mem.load_store_other. 2: eapply CNT_CUR_STORE. + 2:{ left. ii. clarify. apply Genv.find_invert_symbol in FIND_CNT, WFC6. + rewrite FIND_CNT in WFC6. clarify. rename cnt into cnt_cur. + specialize (CNT_INJ _ _ _ CNT_CUR WFC0). clarify. + } + rewrite get_id_tr_app. ss. apply Pos.eqb_neq in n. rewrite n. + rewrite app_nil_r. rewrite WFC8. auto. + } + { hexploit wunchanged_on_exists_mem_free_list. + { eapply store_wunchanged_on. eapply CNT_CUR_STORE. } + eapply FREEENV. intros (m_f & FREE2). esplits. eapply FREE2. + eapply wf_c_cont_wunchanged_on. eapply WFC1. + hexploit wunchanged_on_free_list_preserves. 2: eapply FREEENV. 2: eapply FREE2. 2: auto. + eapply store_wunchanged_on. eapply CNT_CUR_STORE. + } + { ii. rewrite CNT_CUR in H. inv H. ss. } + { move WFNB after FIND_FUN_C. unfold wf_c_nb in *. erewrite Mem.nextblock_store. eapply WFNB. eapply CNT_CUR_STORE. + } + - exists k_c. splits; auto. + move MS1 after FIND_FUN_C. move MCNTS after MS1. destruct MS1 as (MM0 & MM1 & MM2). + unfold mem_delta_apply_wf in DELTA. ss. inv DELTA. + assert (m2 = m1'). + { eapply known_obs_preserves_mem. eapply ECCASES. } + subst m1'. unfold match_mem. splits; auto. + eapply Mem.store_outside_inject. eapply MM0. 2: eapply CNT_CUR_STORE. ss. i. + unfold match_cnts in MCNTS. eapply MCNTS. 3: eapply H. all: eauto. + } + + (* Case 3-2: observables unknown external calls *) + { hexploit external_call_unknowns_fo. eapply ECCASES. intros FO_I. + hexploit external_call_unknowns_val_inject_list. eapply ECCASES. intros ARGS_INJ. + hexploit meminj_first_order_public_first_order. apply FO_I. intros PFO. + clear DELTA_NIL. specialize (DELTA_PUB PFO). desH DELTA_PUB. rename DELTA_PUB0 into INJ0. + move MS1 after ARGS_INJ. destruct MS1 as (MM0 & MM1 & MM2). + hexploit external_call_mem_inject_gen. + { eapply match_symbs_symbols_inject. destruct MS0 as (MS & _). apply MS. } + apply TR2. apply INJ0. apply ARGS_INJ. + intros (j2 & vres2 & m_next' & EC2' & RET_INJ & INJ2 & UCH0 & UCH1 & INCR2 & INJ_SEP). + hexploit external_call_deterministic. eapply EC2. eapply EC2'. intros (EQ1 & EQ2). + subst vres m_next'. clear EC2'. + eapply star_cut_middle. esplits. eapply STAR. + econs 2. + { assert (CROSS_I: crossing_comp ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) (comp_of ef)). + { move TR1 after INJ_SEP. inv TR1. apply H. } + assert (NPTR': not_ptr vretv). + { apply NPTR0. auto. } + eapply step_returnstate. + - i. eapply val_inject_not_ptr; eauto. + - move TR3 after COMP_CUR_F. rewrite COMP_CUR_F in TR3. instantiate (1:=tr3). + inv TR3. econs; [auto |]. ss. + erewrite proj_rettype_to_type_rettype_of_type_eq. 2: apply H0. + + hexploit not_ptr_val_inject_eq; eauto. i; subst vres2. + eapply match_symbs_eventval_match. apply MS0. auto. + } + econs 2. eapply step_skip_or_continue_loop1. left; auto. econs 2. eapply step_skip_loop2. + econs 1. all: ss. + 2:{ unfold unbundle. ss. traceEq. } + + rename m_c' into m_next0. rename DELTA_PUB into DELTA_C. + assert (UCH2: Mem.unchanged_on (fun b _ => forall b0 ofs0, (meminj_public ge_i) b0 <> Some (b, ofs0)) m_next0 m_next). + { eapply Mem.unchanged_on_implies. eapply UCH1. ii. eapply H; eauto. } + assert (UCH3: Mem.unchanged_on (fun b _ => Senv.invert_symbol ge_c b = None) m_next0 m_next). + { eapply Mem.unchanged_on_implies. eapply UCH2. ss. i. unfold meminj_public. des_ifs. ii. clarify. + apply Senv.invert_find_symbol in Heq. destruct MS0 as ((MSE1 & MSE2 & MSE3) & _). apply MSE2 in Heq. + apply Senv.find_invert_symbol in Heq. setoid_rewrite H in Heq. ss. + } + eapply mem_unchanged_wunchanged in UCH3. + hexploit mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. intros UCH4. + hexploit wunchanged_on_trans. eapply UCH4. eapply UCH3. intros UCH5. + hexploit store_wunchanged_on. eapply CNT_CUR_STORE. intros UCH6. + hexploit wunchanged_on_trans. eapply UCH6. eapply UCH5. intros UCH7. + clear UCH3 UCH4 UCH5 UCH6. + + left. exists id_cur. clear STAR. split. + { ss. splits; auto. + - unfold wf_counters. split; auto. + move WFC0 after INJ_SEP. ii. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. + unfold wf_counter in WFC5. des. unfold wf_counter. splits; auto. + exists b1. splits; auto. + + move MCNTS after INJ_SEP. + eapply mem_valid_access_wunchanged_on. + 2: eapply mem_unchanged_wunchanged; eapply UCH2. + eapply mem_delta_apply_wf_valid_access. eapply DELTA_C. + eapply mem_valid_access_wunchanged_on. 2: eapply store_wunchanged_on; eapply CNT_CUR_STORE. + auto. instantiate (1:= fun _ _ => True). ss. + ss. i. erewrite match_symbs_meminj_public. 2: eapply MS0. eapply meminj_public_not_public_not_mapped; eauto. + + destruct (Pos.eq_dec id id_cur). + * subst id. assert (cnt_cur = cnt). + { rewrite WFC0 in CNT_CUR. clarify. } + subst cnt. assert (b1 = cnt_cur_b). + { setoid_rewrite WFC6 in FIND_CNT. clarify. } + subst b1. assert (b0 = cur). + { rewrite FIND_CUR_I in H. clarify. } + subst b0. assert (gd = Gfun (AST.Internal f_cur)). + { apply Genv.find_funct_ptr_iff in INTERNAL. setoid_rewrite INTERNAL in H0. clarify. } + subst gd. + ss. eapply Mem.load_unchanged_on. eapply UCH2. + { ss. i. erewrite match_symbs_meminj_public. 2: eapply MS0. eapply meminj_public_not_public_not_mapped; eauto. } + erewrite mem_delta_apply_wf_mem_load. + 2:{ erewrite match_symbs_mem_delta_apply_wf in DELTA_C. eapply DELTA_C. eapply MS0. } + 2:{ eapply Genv.find_invert_symbol in WFC6. eapply WFC6. } + 2:{ auto. } + erewrite Mem.load_store_same. + 2: setoid_rewrite COMP_CUR_EQ; eapply CNT_CUR_STORE. + { ss. rewrite map_length. rewrite get_id_tr_app. ss. rewrite Pos.eqb_refl. rewrite app_length. ss. + do 2 f_equal. apply nat64_int64_add_one. + clear - BOUND. unfold get_id_tr. eapply Z.le_lt_trans; eauto. + eapply inj_le. rewrite app_length. etransitivity. eapply list_length_filter_le. + apply Nat.le_add_r. + } + * eapply Mem.load_unchanged_on. eapply UCH2. + { ss. i. erewrite match_symbs_meminj_public. 2: eapply MS0. eapply meminj_public_not_public_not_mapped; eauto. } + erewrite mem_delta_apply_wf_mem_load. + 2:{ erewrite match_symbs_mem_delta_apply_wf in DELTA_C. eapply DELTA_C. eapply MS0. } + 2:{ eapply Genv.find_invert_symbol in WFC6. eapply WFC6. } + 2:{ auto. } + ss. erewrite Mem.load_store_other. 2: eapply CNT_CUR_STORE. + { rewrite WFC8. rewrite get_id_tr_app. ss. apply Pos.eqb_neq in n. rewrite n. rewrite app_nil_r. auto. } + { left. ii. clarify. apply Genv.find_invert_symbol in FIND_CNT, WFC6. + rewrite FIND_CNT in WFC6. clarify. rename cnt into cnt_cur. + specialize (CNT_INJ _ _ _ CNT_CUR WFC0). clarify. + } + + - move FREEENV after INJ_SEP. move WFC1 after FREEENV. move WFC4 after FREEENV. + hexploit wunchanged_on_exists_mem_free_list_2. eapply FREEENV. + instantiate (2:=ge_c). eapply UCH7. ss. + intros (m_c' & FREE2). esplits. eapply FREE2. + eapply wf_c_cont_wunchanged_on_2. eapply WFC1. + eapply wunchanged_on_free_list_preserves_gen. 2,3: eauto. auto. + - ii. rewrite CNT_CUR in H. inv H. ss. + - move WFNB after UCH7. eapply wf_c_nb_wunchanged_on; eauto. + } + { exists j2. splits; auto. + { unfold match_mem. splits; auto. move DELTA after UCH7. move TR2 after UCH7. + eapply meminj_not_alloc_delta in MM2. 2: eapply DELTA. + eapply meminj_not_alloc_external_call. eapply MM2. eauto. + } + { ii. assert (NINJP: (meminj_public ge_i) b0 = None). + { move MCNTS after UCH7. specialize (MCNTS _ _ _ H H0 b0 ofs). + destruct (meminj_public ge_i b0) eqn:CASES; ss. exfalso. + destruct p. move MM1 after UCH7. move INCR2 after UCH7. + unfold inject_incr in *. hexploit MM1. apply CASES. hexploit INCR2. apply CASES. + i. rewrite H1 in H2. clarify. + } + specialize (INJ_SEP _ _ _ NINJP H1). des. apply INJ_SEP0. + hexploit Genv.genv_symb_range. eapply H0. intros RANGE. + move WFNB before RANGE. + hexploit mem_delta_apply_wf_wunchanged_on. eapply DELTA_C. intros T1. + hexploit store_wunchanged_on. eapply CNT_CUR_STORE. intros T2. + eapply wunchanged_on_nextblock in T1, T2. revert_until NINJP. clear. i. + unfold wf_c_nb in WFNB. unfold Mem.valid_block. eapply Plt_Ple_trans. eauto. + etransitivity. eapply WFNB. etransitivity; eauto. + } + } + } + + Unshelve. all: try exact (fun _ _ => True). exact 1%positive. exact le. + Qed. + + Lemma ir_to_clight_aux + (ge_i: Asm.genv) (ge_c: Clight.genv) + (WFGE: wf_ge ge_i) + (pretr: bundle_trace) + pist ist + (PREIR: istar (ir_step) ge_i pist pretr ist) + pcst cst + (PREC: star step1 ge_c pcst (unbundle_trace pretr) cst) + ttr cnts pars k id + (BOUND: Z.of_nat (Datatypes.length ttr) < Int64.modulus) + (WFC: wf_c_state ge_i ge_c pretr ttr cnts id cst) + (MS: match_state ge_i ge_c k ttr cnts pars id ist cst) + btr ist' + (TOTAL: ttr = pretr ++ btr) + (STAR: istar (ir_step) ge_i ist btr ist') + : + exists cst', star step1 ge_c cst (unbundle_trace btr) cst'. + Proof. + revert pretr PREIR cst PREC k id WFC MS TOTAL. induction STAR; intros. + { ss. eexists. econs 1. } + rename H into STEP. subst t. ss. + hexploit ir_to_clight_step; eauto. intros; des. + - hexploit IHSTAR. + { eapply istar_trans. eapply PREIR. econs 2. eapply STEP. econs 1. all: ss. } + { rewrite unbundle_trace_app. eapply star_trans. eapply PREC. eapply H. ss. rewrite app_nil_r. ss. } + eauto. eauto. + { rewrite <- app_assoc. ss. } + intros (cst' & INDSTAR). + exists cst'. eapply star_trans. eapply H. eapply INDSTAR. ss. + - subst s2. inv STAR. + + ss. rewrite app_nil_r. eauto. + + inv H0. + Qed. + + Theorem ir_to_clight + (ge_i: Asm.genv) (ge_c: Clight.genv) + (WFGE: wf_ge ge_i) + ist cst + ttr cnts pars k id + (BOUND: Z.of_nat (Datatypes.length ttr) < Int64.modulus) + (WFC: wf_c_state ge_i ge_c [] ttr cnts id cst) + (MS: match_state ge_i ge_c k ttr cnts pars id ist cst) + ist' + (STAR: istar (ir_step) ge_i ist ttr ist') + : + exists cst', star step1 ge_c cst (unbundle_trace ttr) cst'. + Proof. eapply ir_to_clight_aux. eauto. 4,5,6,7: eauto. all: eauto. econs 1. econs 1. Qed. + +End PROOF. diff --git a/security/BacktranslationProof2.v b/security/BacktranslationProof2.v new file mode 100644 index 0000000000..c6a7a13dbd --- /dev/null +++ b/security/BacktranslationProof2.v @@ -0,0 +1,1454 @@ +Require Import String. +Require Import Coqlib Maps Errors Integers Values Memory Globalenvs. +Require Import AST Linking Smallstep Events Behaviors. + +Require Import Split. + +Require Import Tactics. +Require Import riscV.Asm. +Require Import BtBasics BtInfoAsm BtInfoAsmBound MemoryDelta MemoryWeak. +Require Import Ctypes Clight. +Require Import Backtranslation BacktranslationAux BacktranslationProof. +Require Import RSC. + + +Section GENPROOFS. + + Definition next_id0 {A} (l: list (ident * A)) x: ident := + Pos.succ (fold_left (fun x '(i, _) => if (x + (cnt = (id + x0)%positive) /\ (exists gd_a, (In (id, gd_a) gds) /\ (gd_c = gen_counter (comp_of gd_a)))) + (PTree.elements cnts). + Proof. + subst. rewrite Forall_forall. i. destruct x as (id & (cnt & gd_c)). unfold gen_counter_defs in H. + apply PTree.elements_complete in H. apply PTree_Properties.in_of_list in H. + apply list_in_map_inv in H. des. des_ifs. splits; auto. esplits; eauto. + Qed. + + Lemma gen_counter_defs_lt + m agds + id cnt cd + (GET: (gen_counter_defs m agds) ! id = Some (cnt, cd)) + : + (Pos.lt m cnt). + Proof. + hexploit gen_counter_defs_props; eauto. intros FA. rewrite Forall_forall in FA. + apply PTree.elements_correct in GET. specialize (FA _ GET). ss. des. clarify. lia. + Qed. + + Lemma Forall_numbering0 + A (l: list A) + : + forall x1 x2, (x1 <= x2)%positive -> Forall (fun '(id, _) => (x1 <= id)%positive) (numbering x2 l). + Proof. induction l; i; ss. econs. auto. eapply IHl. lia. Qed. + + Lemma Forall_numbering + A (l: list A) + : + forall x, Forall (fun '(id, _) => (x <= id)%positive) (numbering x l). + Proof. i. eapply Forall_numbering0. lia. Qed. + + Lemma map_snd_numbering + A (l: list A) + : + forall x, l = map snd (numbering x l). + Proof. induction l; i; ss. f_equal. eauto. Qed. + + Lemma in_gds_exists_params + gds id gd_i + (FD: (PTree_Properties.of_list gds) ! id = Some gd_i) + (NR: list_norepet (map fst gds)) + x + : + exists ps, (gen_params x gds) ! id = Some ps /\ + Forall (fun '(id, _) => (x <= id)%positive) ps /\ + (match gd_i with + | Gfun fd => map typ_to_type (sig_args (funsig fd)) = map snd ps + | Gvar _ => ps = [] + end). + Proof. + unfold gen_params. + assert (IN: In id (map fst (map (fun '(id0, gd) => + match gen_params_one x gd with + | Some ps0 => (id0, ps0) + | None => (id0, []) + end) gds))). + { apply PTree_Properties.in_of_list in FD. rewrite map_map. + apply (in_map (fun x0 : PTree.elt * globdef Asm.fundef unit => + fst (let '(id0, gd) := x0 in + match gen_params_one x gd with + | Some ps0 => (id0, ps0) + | None => (id0, []) + end))) in FD. des_ifs. + } + apply PTree_Properties.of_list_dom in IN. des. rename v into ps. + setoid_rewrite IN. exists ps. split; auto. + apply PTree_Properties.in_of_list in IN. apply list_in_map_inv in IN. des. des_ifs; ss. + - unfold gen_params_one in Heq. des_ifs. split. + apply Forall_numbering; eauto. + hexploit PTree_Properties.of_list_norepet. eauto. apply IN0. intros GET. + rewrite FD in GET; clarify. eapply map_snd_numbering. + - unfold gen_params_one in Heq. des_ifs. + hexploit PTree_Properties.of_list_norepet. eauto. apply IN0. intros GET. + rewrite FD in GET; clarify. + - unfold gen_params_one in Heq. des_ifs. + hexploit PTree_Properties.of_list_norepet. eauto. apply IN0. intros GET. + rewrite FD in GET; clarify. + Qed. + + Lemma gen_params_props + (gds: list (ident * globdef Asm.fundef unit)) + pars x0 + (CNTS: pars = gen_params x0 gds) + : + Forall (fun '(id, ps) => + exists gd, (In (id, gd) gds) /\ + ((gen_params_one x0 gd = Some ps) \/ (gen_params_one x0 gd = None /\ ps = [])) + ) + (PTree.elements pars). + Proof. + subst. rewrite Forall_forall. i. destruct x as (id & ps). unfold gen_params in H. + apply PTree.elements_complete in H. apply PTree_Properties.in_of_list in H. + apply list_in_map_inv in H. des. des_ifs; esplits; eauto. + Qed. + + Lemma gen_params_one_le + m p t ps + (IN: In (p, t) ps) + gd + (GEN: gen_params_one m gd = Some ps) + : + (m <= p)%positive. + Proof. + unfold gen_params_one in GEN. des_ifs. + hexploit (Forall_numbering _ (map typ_to_type (sig_args (funsig f))) m). intros FA. + rewrite Forall_forall in FA. specialize (FA _ IN). des_ifs. + Qed. + + Lemma gen_params_le + m agds + id ps + (GET: (gen_params m agds) ! id = Some ps) + p t + (IN: In (p, t) ps) + : + Pos.le m p. + Proof. + hexploit gen_params_props; eauto. intros FA. rewrite Forall_forall in FA. + apply PTree.elements_correct in GET. specialize (FA _ GET). ss. des; clarify. + eapply gen_params_one_le; eauto. + Qed. + + Lemma numbering_norepet + A (l: list A) m + : + list_norepet (map fst (numbering m l)). + Proof. + revert_until l. induction l; i; ss. econs. + econs; eauto. ii. apply list_in_map_inv in H. des. destruct x; ss. + hexploit Forall_numbering. i. rewrite Forall_forall in H1. specialize (H1 _ H0). des_ifs. + lia. + Qed. + + Lemma gen_params_one_wf + m gd ps + (FA: gen_params_one m gd = Some ps) + : + list_norepet (var_names ps). + Proof. + unfold gen_params_one in FA. des_ifs. unfold var_names. eapply numbering_norepet. + Qed. + + Lemma gen_params_wf + m agds + : + wf_params_of (gen_params m agds). + Proof. + ii. hexploit gen_params_props; eauto. intros FA. rewrite Forall_forall in FA. + apply PTree.elements_correct in H. specialize (FA _ H). ss. des; clarify; ss. 2: econs. + eapply gen_params_one_wf; eauto. + Qed. + +End GENPROOFS. + +Definition wf_program_public {F V} (p: AST.program F V) := + forall id, In id (AST.prog_public p) -> In id (map fst (AST.prog_defs p)). + + + +Section PROOFGENV. + + Lemma gen_prog_defs_props_1 + (a_ge: Senv.t) tr (gds: list (ident * globdef Asm.fundef unit)) + (gen_gds1: list (ident * globdef Clight.fundef type)) + cnts params + (GEN: gen_gds1 = (map (fun '(id, gd) => (id, gen_progdef a_ge (get_id_tr tr id) gd (cnts ! id) (params ! id))) gds)) + : + Forall (fun '(id, gd_c) => + exists gd_a, (In (id, gd_a) gds) /\ (gd_c = gen_progdef a_ge (get_id_tr tr id) gd_a (cnts ! id) (params ! id))) + gen_gds1. + Proof. + subst gen_gds1. rewrite Forall_map. apply Forall_forall. i. des_ifs. esplits; eauto. + Qed. + + Lemma gen_prog_defs_inv_1 + (a_ge: Senv.t) tr (gds: list (ident * globdef Asm.fundef unit)) + (gen_gds1: list (ident * globdef Clight.fundef type)) + cnts params + (GEN: gen_gds1 = (map (fun '(id, gd) => (id, gen_progdef a_ge (get_id_tr tr id) gd (cnts ! id) (params ! id))) gds)) + id gd + (IN: In (id, gd) gds) + : + In (id, gen_progdef a_ge (get_id_tr tr id) gd (cnts ! id) (params ! id)) gen_gds1. + Proof. + eapply (in_map (fun '(id0, gd0) => (id0, gen_progdef a_ge (get_id_tr tr id0) gd0 cnts ! id0 params ! id0))) in IN. clarify. + Qed. + + Lemma gen_counter_defs_inv + (gds: list (ident * globdef Asm.fundef unit)) + (NR: list_norepet (map fst gds)) + cnts x0 + (CNTS: cnts = gen_counter_defs x0 gds) + id gd + (IN: In (id, gd) gds) + : + cnts ! id = Some ((id + x0)%positive, gen_counter (comp_of gd)). + Proof. + subst. unfold gen_counter_defs. apply PTree_Properties.of_list_norepet. + { rewrite map_map. + match goal with + | [|- list_norepet (map ?f gds)] => assert (f = fst) + end. + { extensionalities s. des_ifs. } + rewrite H. auto. + } + { eapply (in_map (fun '(id0, gd0) => (id0, ((id0 + x0)%positive, gen_counter (comp_of gd0))))) in IN. auto. } + Qed. + + Lemma gen_counter_defs_inj + (gds: list (ident * globdef Asm.fundef unit)) + (NR: list_norepet (map fst gds)) + cnts x0 + (CNTS: cnts = gen_counter_defs x0 gds) + : + forall (id0 id1 : positive) (cnt : ident) gd0 gd1, + cnts ! id0 = Some (cnt, gd0) -> cnts ! id1 = Some (cnt, gd1) -> (id0 = id1 /\ gd0 = gd1). + Proof. + i. hexploit gen_counter_defs_props. eauto. i. rewrite Forall_forall in H1. + pose proof (PTree.elements_correct _ _ H) as IN1. pose proof (PTree.elements_correct _ _ H0) as IN2. + hexploit (H1 _ IN1). hexploit (H1 _ IN2). clear H1. i. des. clarify. apply Pos.add_reg_r in H2. subst id1. clarify. + rewrite H. split; auto. + Qed. + + Definition get_cnt_ids (cnts0: PTree.t (ident * globdef fundef type)): cnt_ids := + PTree.map (fun id '(cnt, _) => cnt) cnts0. + + Lemma gen_counter_defs_cnt_ids_inj + (gds: list (ident * globdef Asm.fundef unit)) + (NR: list_norepet (map fst gds)) + cnts0 x0 + (CNTS0: cnts0 = gen_counter_defs x0 gds) + (cnts: cnt_ids) + (CNTS: cnts = get_cnt_ids cnts0) + : + forall (id0 id1 : positive) (cnt : ident), + cnts ! id0 = Some cnt -> cnts ! id1 = Some cnt -> id0 = id1. + Proof. + i. subst. unfold get_cnt_ids in *. rewrite PTree.gmap in H0, H. unfold option_map in *. des_ifs. + hexploit gen_counter_defs_inj. eauto. eauto. apply Heq0. apply Heq. intros (EQ & _). auto. + Qed. + + Lemma in_prog_defs_gen_program + p_a btr gds + (GDS: gds = AST.prog_defs p_a) + id gd_a + (IN: In (id, gd_a) gds) + : + exists gd_c, + (In (id, gd_c) (prog_defs (gen_program btr p_a))) /\ + (let m0 := next_id gds in + let cnts := gen_counter_defs m0 gds in + let cnt_defs := map snd (PTree.elements cnts) in + let m1 := next_id cnt_defs in + let params := gen_params m1 gds in + gd_c = gen_progdef (Genv.globalenv p_a) (get_id_tr btr id) gd_a (cnts ! id) (params ! id)). + Proof. + ss. esplits. 2: eauto. unfold gen_prog_defs. apply in_or_app. left. subst. + eapply (in_map (fun '(id0, gd) => + (id0, gen_progdef (Genv.globalenv p_a) (get_id_tr btr id0) gd + (gen_counter_defs (next_id (AST.prog_defs p_a)) (AST.prog_defs p_a)) ! id0 + (gen_params (next_id (map snd (PTree.elements (gen_counter_defs (next_id (AST.prog_defs p_a)) (AST.prog_defs p_a))))) + (AST.prog_defs p_a)) ! id0))) in IN. ss. + Qed. + + Lemma genv_find_symbol_add_global_other + F V (ge0: Genv.t F V) + (gd: (ident * globdef F V)) + id + (NEQ: fst gd <> id) + : + Genv.find_symbol (Genv.add_global ge0 gd) id = Genv.find_symbol ge0 id. + Proof. unfold Genv.add_global, Genv.find_symbol. ss. rewrite PTree.gso; auto. Qed. + + Lemma genv_find_symbol_add_globals_other + F V (ge0: Genv.t F V) + (gds: list (ident * globdef F V)) + id + (NEQ: Forall (fun '(id0, _) => id0 <> id) gds) + : + Genv.find_symbol (Genv.add_globals ge0 gds) id = Genv.find_symbol ge0 id. + Proof. + move NEQ after ge0. revert_until NEQ. induction NEQ; i; ss. rewrite IHNEQ. + des_ifs. eapply genv_find_symbol_add_global_other. ss. + Qed. + + Lemma genv_find_def_add_globals + F V + (gds: list (ident * globdef F V)) + ge0 b + (BLK: (b < Genv.genv_next ge0)%positive) + : + Genv.find_def (Genv.add_globals ge0 gds) b = Genv.find_def ge0 b. + Proof. + revert_until gds. induction gds; ii; ss. + destruct a as (idx & gdx). rewrite IHgds. + 2:{ ss. lia. } + unfold Genv.find_def, Genv.add_global. ss. rewrite PTree.gso; auto. + { ii. lia. } + Qed. + + Lemma genv_find_def_add_globals_2 + F V + (gds: list (ident * globdef F V)) + ge0 id gda + : + Genv.find_def (Genv.add_globals (Genv.add_global ge0 (id, gda)) gds) (Genv.genv_next ge0) = Some gda. + Proof. + rewrite genv_find_def_add_globals. + { unfold Genv.find_def, Genv.add_global. ss. rewrite PTree.gss. auto. } + { ss. lia. } + Qed. + + Lemma genv_find_symbol_add_globals_some + F V + (gds: list (ident * globdef F V)) + id + (IN: In id (map (fun x => fst x) gds)) + (ge0: Genv.t F V) b + (FIND: Genv.find_symbol (Genv.add_globals ge0 gds) id = Some b) + : + exists gd id0, (Genv.find_def (Genv.add_globals ge0 gds) b = Some gd) /\ (In (id0, gd) gds). + Proof. + revert_until gds. induction gds; i; ss. + destruct a as (ida & gda). ss. des; clarify. + - destruct (in_dec Pos.eq_dec id (map fst gds)). + + specialize (IHgds _ i _ _ FIND). des. esplits; eauto. + + clear IHgds. rewrite genv_find_symbol_add_globals_other in FIND. + * unfold Genv.find_symbol, Genv.add_global in FIND. ss. rewrite PTree.gss in FIND. clarify. + exists gda, id. split; auto. apply genv_find_def_add_globals_2. + * apply Forall_forall. i. destruct x as (idx & gdx). ii. subst. apply n. apply (in_map fst) in H. ss. + - specialize (IHgds _ IN _ _ FIND). des. esplits; eauto. + Qed. + + Lemma genv_find_symbol_add_globals_map + F0 V0 F1 V1 + id b l + (ge0: Genv.t F0 V0) (ge1: Genv.t F1 V1) + (NB: (Genv.genv_next ge0) = (Genv.genv_next ge1)) + (FIND: Genv.find_symbol (Genv.add_globals ge0 l) id = Some b) + gd + (IN: In (id, gd) l) + f f' + (FUN: f' = fun '(id, x) => (id, f (id, x))) + : + Genv.find_symbol (Genv.add_globals ge1 (map f' l)) id = Some b. + Proof. + subst f'. revert_until l. induction l; i; ss. + destruct a as (id0 & gd0); ss. des. + { clarify. destruct (in_dec Pos.eq_dec id (map fst l)). + { eapply list_in_map_inv in i. des. destruct x as (id' & gd'). ss. subst id'. eapply IHl; eauto. + unfold Genv.genv_next, Genv.add_global. rewrite NB. auto. + } + { clear IHl. rewrite genv_find_symbol_add_globals_other. + - rewrite genv_find_symbol_add_globals_other in FIND. + + unfold Genv.find_symbol, Genv.add_global in *. ss. rewrite PTree.gss in *. rewrite <- NB. auto. + + apply Forall_forall. i. des_ifs. ii. subst i. apply n. apply (in_map fst) in H. ss. + - rewrite Forall_map. apply Forall_forall. i. des_ifs. ii. subst i. apply n. apply (in_map fst) in H. ss. + } + } + { eapply IHl; eauto. unfold Genv.genv_next, Genv.add_global. rewrite NB. auto. } + Qed. + + Lemma gen_program_symbs_find + p_a btr + p_c ge_a ge_c + (P_C: p_c = gen_program btr p_a) + (GE_A: ge_a = Genv.globalenv p_a) + (GE_C: ge_c = globalenv p_c) + : + symbs_find ge_a ge_c. + Proof. + subst p_c ge_a ge_c. ii. ss. hexploit Genv.find_symbol_inversion. eapply H. intros IN_A. + unfold prog_defs_names in IN_A. apply list_in_map_inv in IN_A. des. destruct x as (id0 & gd_a). ss. subst id0. + unfold Genv.globalenv. ss. unfold gen_prog_defs. rewrite Genv.add_globals_app. rewrite genv_find_symbol_add_globals_other. + { eapply genv_find_symbol_add_globals_map; eauto. ss. extensionalities. des_ifs. f_equal. + instantiate (1:= fun '(i, g) => + gen_progdef (Genv.globalenv p_a) (get_id_tr btr i) g (gen_counter_defs (next_id (AST.prog_defs p_a)) (AST.prog_defs p_a)) ! i + (gen_params (next_id (map snd (PTree.elements (gen_counter_defs (next_id (AST.prog_defs p_a)) (AST.prog_defs p_a))))) + (AST.prog_defs p_a)) ! i). ss. + } + { hexploit gen_counter_defs_props. eauto. intros FA. + eapply Forall_map. eapply Forall_impl. 2: eapply FA. clear FA. ss. i. des_ifs. des; ss; clarify. + assert (BIG: (id < next_id (AST.prog_defs p_a))%positive). + { eapply next_id_lt; eauto. } + lia. + } + Qed. + + Lemma gen_program_symbs_public + p_a btr + p_c ge_a ge_c + (WFPP: wf_program_public p_a) + (P_C: p_c = gen_program btr p_a) + (GE_A: ge_a = Genv.globalenv p_a) + (GE_C: ge_c = globalenv p_c) + : + symbs_public ge_a ge_c. + Proof. + subst p_c ge_a ge_c. ss. unfold symbs_public. i. ss. unfold Genv.public_symbol. + rewrite ! Genv.globalenv_public. destruct (Genv.find_symbol (Genv.globalenv p_a) id) eqn:FIND_A. + { eapply gen_program_symbs_find in FIND_A; auto. ss. rewrite FIND_A. ss. } + des_ifs. destruct (in_dec ident_eq id (AST.prog_public (gen_program btr p_a))); ss. exfalso. + apply WFPP in i. apply list_in_map_inv in i. des. destruct x; clarify. + apply Genv.find_symbol_exists in i0. des. ss. clarify. + Qed. + + Lemma pos_neq_dec (id: positive): forall id0, {id0 <> id} + {~ id0 <> id}. + Proof. i. destruct (Pos.eq_dec id0 id); clarify; auto. Qed. + + Lemma genv_find_symbol_gen_cases + (p_a: Asm.program) btr + id b + (FIND: Genv.find_symbol (Genv.globalenv (gen_program btr p_a)) id = Some b) + : + (Genv.find_symbol (Genv.globalenv p_a) id = Some b) \/ + (Genv.find_symbol (Genv.globalenv p_a) id = None /\ + exists cp, Genv.find_def (Genv.globalenv (gen_program btr p_a)) b = Some (gen_counter cp)). + Proof. + destruct (Genv.find_symbol (Genv.globalenv p_a) id) eqn:FIND_A. + { left. eapply gen_program_symbs_find in FIND_A; eauto. ss. setoid_rewrite FIND in FIND_A. clarify. } + { right. split; auto. + unfold Genv.globalenv in *. ss. unfold gen_prog_defs in *. rewrite Genv.add_globals_app in FIND. + destruct (Forall_Exists_dec _ (pos_neq_dec id) (map fst (map snd (PTree.elements (gen_counter_defs (next_id (AST.prog_defs p_a)) (AST.prog_defs p_a)))))). + - exfalso. + rewrite genv_find_symbol_add_globals_other in FIND. + 2:{ rewrite Forall_map in f. eapply Forall_impl. 2: apply f. ss. i. des_ifs. } + set ({| + prog_defs := (map + (fun '(id, gd) => + (id, + gen_progdef (Genv.globalenv p_a) (get_id_tr btr id) gd + (gen_counter_defs (next_id (AST.prog_defs p_a)) (AST.prog_defs p_a)) ! id + (gen_params + (next_id (map snd (PTree.elements (gen_counter_defs (next_id (AST.prog_defs p_a)) (AST.prog_defs p_a))))) + (AST.prog_defs p_a)) ! id)) (AST.prog_defs p_a)); + prog_public := AST.prog_public p_a; + prog_main := AST.prog_main p_a; + prog_pol := AST.prog_pol p_a; + prog_types := []; + prog_comp_env := PTree.empty composite; + prog_comp_env_eq := (fun (_ : bundle_trace) (_ : Asm.program) => Backtranslation.gen_program_obligation_1) btr p_a + |}) as p_t. + hexploit Genv.find_symbol_find_def_inversion. + { instantiate (3:=p_t). unfold Genv.globalenv. subst p_t. ss. eapply FIND. } + intros (g & FIND_C_DEF). + assert (PDM: (prog_defmap p_t) ! id = Some g). + { rewrite Genv.find_def_symbol. esplits; eauto. } + unfold prog_defmap in PDM. apply PTree_Properties.in_of_list in PDM. subst p_t; ss. + apply list_in_map_inv in PDM. des. destruct x as (idx & gdx). clarify. + apply Genv.find_symbol_exists in PDM0. des. unfold Genv.globalenv in PDM0. rewrite FIND_A in PDM0. clarify. + - rewrite map_map in e. rewrite Exists_exists in e. des. apply Classical_Prop.NNPP in e0. subst x. + hexploit genv_find_symbol_add_globals_some. + 2:{ eapply FIND. } + { rewrite map_map. auto. } + intros. des. hexploit gen_counter_defs_props. + { instantiate (1:=(AST.prog_defs p_a)). instantiate (1:=(next_id (AST.prog_defs p_a))). auto. } + intros FA. rewrite Forall_forall in FA. apply list_in_map_inv in H0. des. specialize (FA x H1). des_ifs. des; clarify. + ss. clarify. rewrite Genv.add_globals_app. eauto. + } + Qed. + + Lemma in_gds_exists_cnt + gds id gd_i + (FD: (PTree_Properties.of_list gds) ! id = Some gd_i) + x + : + exists cnt, (get_cnt_ids (gen_counter_defs x gds)) ! id = Some cnt /\ (x < cnt)%positive. + Proof. + unfold get_cnt_ids, gen_counter_defs. + assert (IN: In id (map fst (map (fun '(id0, gd) => (id0, ((id0 + x)%positive, gen_counter (comp_of gd)))) gds))). + { apply PTree_Properties.in_of_list in FD. rewrite map_map. + apply (in_map (fun x0 : positive * globdef Asm.fundef unit => fst (let '(id0, gd) := x0 in (id0, ((id0 + x)%positive, gen_counter (comp_of gd)))))) in FD. ss. + } + apply PTree_Properties.of_list_dom in IN. des. destruct v. + rewrite PTree.gmap. setoid_rewrite IN. ss. esplits; eauto. + apply PTree_Properties.in_of_list in IN. apply list_in_map_inv in IN. des. des_ifs. lia. + Qed. + + Lemma in_asm_in_gen + p_a btr + p_c ge_a ge_c + (P_C: p_c = gen_program btr p_a) + (GE_A: ge_a = Genv.globalenv p_a) + (GE_C: ge_c = globalenv p_c) + id gd_a + (FD: (prog_defmap p_a) ! id = Some gd_a) + gds + (GDS: gds = AST.prog_defs p_a) + x0 cnt + (X0: x0 = next_id gds) + (IN_CNT : (get_cnt_ids (gen_counter_defs x0 gds)) ! id = Some cnt) + x1 ps + (X1: x1 = next_id (map snd (PTree.elements (gen_counter_defs x0 gds)))) + (IN_PS : (gen_params x1 gds) ! id = Some ps) + (NR_GEN: list_norepet (prog_defs_names p_c)) + : + (prog_defmap p_c) ! id = + Some (gen_globdef ge_a cnt ps (get_id_tr btr id) gd_a). + Proof. + subst. apply in_prog_defmap in FD. eapply in_prog_defs_gen_program in FD; eauto. + des. assert (FD': In (id, gd_c) (AST.prog_defs (gen_program btr p_a))). + { eapply FD. } + hexploit prog_defmap_norepet. 2: eapply FD'. auto. + intros EQ. rewrite EQ. clear EQ FD'. ss. subst gd_c. + unfold gen_progdef. + rewrite IN_PS. unfold get_cnt_ids in IN_CNT. rewrite PTree.gmap in IN_CNT. + destruct ((gen_counter_defs (next_id (AST.prog_defs p_a)) (AST.prog_defs p_a)) ! id) eqn:CNT; ss. + destruct p. clarify. + Qed. + + Lemma gen_counter_defs_list_norepet + x gds + (NR: list_norepet (map fst gds)) + : + list_norepet (map (fun x => fst (snd x)) (PTree.elements (gen_counter_defs x gds))). + Proof. + eapply list_map_norepet. + { hexploit PTree.elements_keys_norepet. intros A. apply list_map_norepet_rev in A. eauto. } + i. destruct x0 as (idx & (cntx & gdx)). destruct y as (idy & (cnty & gdy)). + apply PTree.elements_complete in H, H0. ss. + destruct (Pos.eqb_spec idx idy). + { subst. rewrite H0 in H. clarify. } + { destruct (Pos.eqb_spec cntx cnty); auto. + subst. hexploit gen_counter_defs_inj. eauto. 2: apply H. 2: apply H0. eauto. + i. des; clarify. + } + Qed. + + Lemma gen_counter_defs_list_disjoint + gds x + (BOUND: ((next_id gds) <= x)%positive) + : + list_disjoint (map fst gds) + (map (fun x => fst (snd x)) (PTree.elements (gen_counter_defs x gds))). + Proof. + ii. subst. apply list_in_map_inv in H, H0. des. destruct x1, x0. ss. clarify. + destruct p0 as (cnt & g_cnt). ss. rename p into id. + apply PTree.elements_complete in H1. apply gen_counter_defs_lt in H1. + hexploit next_id_lt. apply H2. i. lia. + Qed. + + Lemma gen_program_list_norepet + p_a btr + (NR: list_norepet (prog_defs_names p_a)) + : + list_norepet (prog_defs_names (gen_program btr p_a)). + Proof. + unfold prog_defs_names, gen_program in *. ss. unfold gen_prog_defs. + rewrite map_app. rewrite ! map_map. + match goal with + | [|- list_norepet (?l ++ _)] => assert (EQ: l = map fst (AST.prog_defs p_a)) + end. + { f_equal. extensionalities x. destruct x; ss. } + rewrite EQ. clear EQ. rewrite list_norepet_app. splits; auto. + apply gen_counter_defs_list_norepet; auto. + apply gen_counter_defs_list_disjoint; auto. lia. + Qed. + + Lemma gen_program_match_find_def + p_a btr + p_c ge_a ge_c + (P_C: p_c = gen_program btr p_a) + (GE_A: ge_a = Genv.globalenv p_a) + (GE_C: ge_c = globalenv p_c) + gds + (GDS: gds = AST.prog_defs p_a) + x0 cnts + (X0: x0 = next_id gds) + (CNTS: cnts = get_cnt_ids (gen_counter_defs x0 gds)) + x1 pars + (X1: x1 = next_id (map snd (PTree.elements (gen_counter_defs x0 gds)))) + (PARS: pars = gen_params x1 gds) + (NR: list_norepet (prog_defs_names p_a)) + : + match_find_def ge_a ge_c cnts pars btr. + Proof. + subst. ii. assert (FD: (prog_defmap p_a) ! id = Some gd_i). + { rewrite Genv.find_def_symbol. apply Senv.invert_find_symbol in H0. ss. esplits; eauto. } + unfold prog_defmap in FD. set (AST.prog_defs p_a) as gds in *. + hexploit in_gds_exists_cnt. eapply FD. intros (cnt & IN_CNT). + hexploit in_gds_exists_params. eapply FD. apply NR. intros (ps & IN_PS). + des. rewrite IN_CNT, IN_PS. + hexploit in_asm_in_gen. 4: apply FD. 6: apply IN_CNT. 7: apply IN_PS. all: eauto. + { apply gen_program_list_norepet. auto. } + instantiate (1:=btr). intros FD_C. rewrite Genv.find_def_symbol in FD_C. des. + apply Senv.invert_find_symbol in H0. ss. eapply gen_program_symbs_find in H0; eauto. + ss. setoid_rewrite FD_C in H0. clarify. + Qed. + + Lemma gen_program_symbs_volatile + p_a btr + p_c ge_a ge_c + (P_C: p_c = gen_program btr p_a) + (GE_A: ge_a = Genv.globalenv p_a) + (GE_C: ge_c = globalenv p_c) + (NR: list_norepet (prog_defs_names p_a)) + : + symbs_volatile ge_a ge_c. + Proof. + unfold symbs_volatile. i. unfold Senv.block_is_volatile. ss. + unfold Genv.block_is_volatile. destruct (Genv.find_var_info ge_a b) eqn:VAR_A. + { rewrite Genv.find_var_info_iff in VAR_A. hexploit wf_ge_block_to_id. 2: eapply VAR_A. + { subst ge_a. apply wf_program_wf_ge. ss. } + intros (id & INV_A). + hexploit gen_program_match_find_def; eauto. intros MFD. + unfold match_find_def in MFD. specialize (MFD _ _ _ VAR_A INV_A). des_ifs. + 2:{ ss. rewrite <- Genv.find_var_info_iff in MFD. rewrite MFD in Heq. ss. } + ss. rewrite Genv.find_var_info_iff in Heq. rewrite MFD in Heq. clarify. + } + { des_ifs. rewrite Genv.find_var_info_iff in Heq. + hexploit @genv_def_to_ident. 3: eapply Heq. eapply gen_program_list_norepet; eauto. ss. + intros (id & INV). apply Genv.invert_find_symbol in INV. + hexploit genv_find_symbol_gen_cases. apply INV. intros CASES. des. + { exfalso. unfold Genv.find_var_info in VAR_A. des_ifs. + 2:{ apply Genv.find_symbol_find_def_inversion in CASES. des. clarify. } + apply Genv.find_invert_symbol in CASES. hexploit gen_program_match_find_def; eauto. + intros MFD. unfold match_find_def in MFD. specialize (MFD _ _ _ Heq0 CASES). + des_ifs. rewrite Heq in MFD. ss. + } + setoid_rewrite Heq in CASES0. clarify. + } + Qed. + + Lemma gen_program_eq_policy + p_a btr + p_c ge_a ge_c + (P_C: p_c = gen_program btr p_a) + (GE_A: ge_a = Genv.globalenv p_a) + (GE_C: ge_c = globalenv p_c) + : + eq_policy ge_a ge_c. + Proof. + subst. unfold eq_policy. ss. unfold Genv.globalenv. ss. + rewrite ! Genv.genv_pol_add_globals. ss. + Qed. + + Lemma gen_program_match_symbs + p_a btr + p_c ge_a ge_c + (P_C: p_c = gen_program btr p_a) + (GE_A: ge_a = Genv.globalenv p_a) + (GE_C: ge_c = globalenv p_c) + (WFPP: wf_program_public p_a) + (NR: list_norepet (prog_defs_names p_a)) + : + match_symbs ge_a ge_c. + Proof. + unfold match_symbs. splits. + eapply gen_program_symbs_public; eauto. + eapply gen_program_symbs_find; eauto. + eapply gen_program_symbs_volatile; eauto. + Qed. + + Lemma gen_program_match_genv + p_a btr + p_c ge_a ge_c + (P_C: p_c = gen_program btr p_a) + (GE_A: ge_a = Genv.globalenv p_a) + (GE_C: ge_c = globalenv p_c) + (WFPP: wf_program_public p_a) + (NR: list_norepet (prog_defs_names p_a)) + : + match_genv ge_a ge_c. + Proof. + unfold match_genv. splits. eapply gen_program_match_symbs; eauto. + eapply gen_program_eq_policy; eauto. + Qed. + +End PROOFGENV. + + +Section PROOFINIT. + + Lemma gen_counter_defs_alloc + x0 gds cnts + (CNTS: cnts = gen_counter_defs x0 gds) + F V (ge: Genv.t F V) + : + Forall (fun (idg: ident * (globdef fundef type)) => + let (_, y) := idg in + match y with + | Gfun _ => False + | Gvar v => + Genv.init_data_list_aligned 0 (gvar_init v) /\ + (forall (i : ident) (o : ptrofs), In (Init_addrof i o) (gvar_init v) -> exists b : block, Genv.find_symbol ge i = Some b) + end) (map snd (PTree.elements cnts)). + Proof. + apply Forall_forall. intros (idx & gdx) IN. hexploit (gen_counter_defs_props _ _ _ CNTS). + intros FA. rewrite Forall_forall in FA. apply list_in_map_inv in IN. des. + destruct x as (id & (cnt & gd)). ss. clarify. specialize (FA _ IN0). ss. des. + subst. ss. splits; auto. apply Z.divide_0_r. i. des; ss. + Qed. + + Lemma genv_store_init_data_eq + (ge_a: Asm.genv) (ge_c: Clight.genv) + (SF: symbs_find ge_a ge_c) + a m b z cp m' + (SOME: Genv.store_init_data ge_a m b z a cp = Some m') + : + Genv.store_init_data ge_c m b z a cp = Some m'. + Proof. + destruct a; ss. destruct (Genv.find_symbol ge_a i) eqn:FIND; ss. + apply SF in FIND. setoid_rewrite FIND. ss. + Qed. + + Lemma genv_store_init_data_list_eq + (ge_a: Asm.genv) (ge_c: Clight.genv) + (SF: symbs_find ge_a ge_c) + l m b z cp m' + (SOME: Genv.store_init_data_list ge_a m b z l cp = Some m') + : + Genv.store_init_data_list ge_c m b z l cp = Some m'. + Proof. + revert_until l. induction l; i; ss. + destruct (Genv.store_init_data ge_a m b z a cp) eqn:MEM; ss. + eapply genv_store_init_data_eq in MEM; eauto. rewrite MEM. eauto. + Qed. + + Lemma gen_progdef_exists_alloc_global + (ge_a: Asm.genv) (ge_c: Clight.genv) + (SF: symbs_find ge_a ge_c) + m0 id gd m1 + (AG: Genv.alloc_global ge_a m0 (id, gd) = Some m1) + btr cnt ps + : + Genv.alloc_global ge_c m0 (id, gen_progdef ge_a btr gd (Some cnt) (Some ps)) = Some m1. + Proof. + ss. destruct cnt as (cnt & cnt_def). destruct gd; ss. + { replace (comp_of (gen_fundef ge_a cnt ps btr f)) with (comp_of f). + 2:{ unfold gen_fundef. des_ifs. } + ss. + } + { replace (Genv.perm_globvar (gen_globvar v)) with (Genv.perm_globvar v). + 2:{ ss. } + destruct (Mem.alloc m0 (gvar_comp v) 0 (init_data_list_size (gvar_init v))) as (ma & b). + destruct (store_zeros ma b 0 (init_data_list_size (gvar_init v)) (gvar_comp v)); ss. + destruct (Genv.store_init_data_list ge_a m b 0 (gvar_init v) (gvar_comp v)) eqn:MEM; ss. + hexploit genv_store_init_data_list_eq; eauto. intros EQ. rewrite EQ. ss. + } + Qed. + + Lemma gen_program_exists_init_mem_1_aux + (ge_a: Asm.genv) (ge_c: Clight.genv) + (SF: symbs_find ge_a ge_c) + (gds: list (ident * globdef Asm.fundef unit)) + m0 m_a + (MEMA : Genv.alloc_globals ge_a m0 gds = Some m_a) + btr cnts pars + (CNTS: forall id, In id (map fst gds) -> exists cnt, cnts ! id = Some cnt) + (PARS: forall id, In id (map fst gds) -> exists ps, pars ! id = Some ps) + : + Genv.alloc_globals ge_c m0 + (map (fun '(id, gd) => (id, gen_progdef ge_a (get_id_tr btr id) gd cnts ! id pars ! id)) gds) = Some m_a. + Proof. + revert_until gds. induction gds; i; ss. eauto. + destruct (Genv.alloc_global ge_a m0 a) eqn:ALLOC; ss. + destruct a as (id & gd). + hexploit CNTS. left; ss. intros (cnt & GET_CNT). + hexploit PARS. left; ss. intros (ps & GET_PS). + rewrite GET_CNT, GET_PS. + hexploit gen_progdef_exists_alloc_global. 2: eapply ALLOC. eauto. + intros ALLOC2. rewrite ALLOC2. + eapply IHgds; eauto. + Qed. + + Lemma gen_program_exists_init_mem_1 + p btr + p_c ge_a ge_c + (P_C: p_c = gen_program btr p) + (GE_A: ge_a = Genv.globalenv p) + (GE_C: ge_c = globalenv p_c) + (NR: list_norepet (map fst (AST.prog_defs p))) + m0 m_a + (MEMA : Genv.alloc_globals ge_a m0 (AST.prog_defs p) = Some m_a) + : + Genv.alloc_globals ge_c m0 + (map + (fun '(id, gd) => + (id, + gen_progdef ge_a (get_id_tr btr id) gd + (gen_counter_defs (next_id (AST.prog_defs p)) (AST.prog_defs p)) ! id + (gen_params + (next_id + (map snd + (PTree.elements + (gen_counter_defs (next_id (AST.prog_defs p)) (AST.prog_defs p))))) + (AST.prog_defs p)) ! id)) (AST.prog_defs p)) = Some m_a. + Proof. + eapply gen_program_exists_init_mem_1_aux; auto. + { subst. eapply gen_program_symbs_find; auto. } + eauto. + { i. apply PTree_Properties.of_list_dom in H. des. + eapply in_gds_exists_cnt in H. des. unfold get_cnt_ids in H. rewrite PTree.gmap in H. + unfold option_map in H. des_ifs. eauto. + } + { i. apply PTree_Properties.of_list_dom in H. des. + eapply in_gds_exists_params in H; auto. des. eauto. + } + Qed. + + Lemma genv_alloc_globals_exists + ge + gds + (FA: Forall (fun (idg: ident * (globdef fundef type)) => + let (_, y) := idg in + match y with + | Gfun _ => True + | Gvar v => + Genv.init_data_list_aligned 0 (gvar_init v) /\ + (forall (i : ident) (o : ptrofs), In (Init_addrof i o) (gvar_init v) -> exists b : block, Genv.find_symbol ge i = Some b) + end) gds) + m + : + exists m', Genv.alloc_globals ge m gds = Some m'. + Proof. + revert_until FA. induction FA; i; ss. eauto. + hexploit Genv.alloc_global_exists. eapply H. intros (m' & ALLOC). + rewrite ALLOC. eauto. + Qed. + + Lemma gen_program_exists_init_mem + btr (p: Asm.program) + m_a + (MEMA: Genv.init_mem p = Some m_a) + (NR: list_norepet (map fst (AST.prog_defs p))) + : + exists m_c, Genv.init_mem (gen_program btr p) = Some m_c. + Proof. + unfold Genv.init_mem in *. ss. unfold gen_prog_defs. + hexploit gen_program_exists_init_mem_1; auto. eauto. apply MEMA. + intros ALLOC1. erewrite <- Genv.alloc_globals_app. + 2:{ apply ALLOC1. } + eapply genv_alloc_globals_exists. eapply Forall_impl. 2: eapply gen_counter_defs_alloc; eauto. + i. destruct a as (ida & gda). des_ifs. des. splits; eauto. + Qed. + + Lemma gen_program_split_init_mem + btr (p: Asm.program) + m_a + (MEMA: Genv.init_mem p = Some m_a) + (NR: list_norepet (map fst (AST.prog_defs p))) + m_c + (MEMC: Genv.init_mem (gen_program btr p) = Some m_c) + : + Genv.alloc_globals (Genv.globalenv (gen_program btr p)) m_a (map snd (PTree.elements (gen_counter_defs (next_id (AST.prog_defs p)) (AST.prog_defs p)))) = Some m_c. + Proof. + unfold Genv.init_mem in *. ss. unfold gen_prog_defs in *. + hexploit gen_program_exists_init_mem_1; auto. eauto. apply MEMA. + intros ALLOC1. erewrite Genv.alloc_globals_app. apply MEMC. apply ALLOC1. + Qed. + + Lemma gen_program_prog_main_eq + p btr + : + prog_main (gen_program btr p) = AST.prog_main p. + Proof. ss. Qed. + + Lemma exists_initial_state + p ist + (INIT: ir_initial_state p ist) + (WFMAINSIG: wf_main_sig p) + (NR: list_norepet (map fst (AST.prog_defs p))) + btr + : + exists f m_c, initial_state (gen_program btr p) (Callstate (Internal f) [] Kstop m_c) + /\ + ((fn_params f = []) /\ (fn_vars f = []) /\ (fn_temps f = [])). + Proof. + inv INIT. des. hexploit gen_program_exists_init_mem; eauto. intros (m_c & INIT_MC). + hexploit gen_program_match_find_def; eauto. intros MFD. unfold match_find_def in MFD. + ss. hexploit Genv.find_invert_symbol. eapply H. intros INV_A. + specialize (WFMAINSIG _ _ H H0). + rewrite Genv.find_funct_ptr_iff in H0. specialize (MFD _ _ _ H0 INV_A). + des_ifs. ss. rewrite <- Genv.find_funct_ptr_iff in MFD. + assert (l = []). + { hexploit in_gds_exists_params. + { eapply PTree_Properties.of_list_norepet. eauto. apply in_prog_defmap. + rewrite Genv.find_def_symbol. exists cur. splits; eauto. + } + auto. + intros. des. rewrite Heq0 in H2. clarify. ss. rewrite WFMAINSIG in *. ss. + symmetry in H4. apply map_eq_nil in H4. subst. ss. + } + subst. do 2 eexists. split. + - econs; eauto. + { rewrite gen_program_prog_main_eq. eapply gen_program_symbs_find in H; ss; eauto. apply H. } + { ss. unfold gen_function, type_of_function. ss. rewrite WFMAINSIG in *. ss. } + - ss. + Qed. + + Lemma mem_unchanged_on_inject + j m m1 + (INJ: Mem.inject j m m1) + P m2 + (UCH: Mem.unchanged_on P m1 m2) + : + (forall b1 b2 ofs delta, j b1 = Some (b2, delta) -> P b2 (ofs + delta)) -> + Mem.inject j m m2. + Proof. + i. inv INJ. inv UCH. econs; eauto. + - inv mi_inj. econs; eauto. + + i. rewrite <- unchanged_on_perm. all: eauto. + + i. rewrite <- unchanged_on_own. all: eauto. + + i. rewrite unchanged_on_contents. all: eauto. + - i. eapply mi_mappedblocks in H0. clear - H0 unchanged_on_nextblock. + unfold Mem.valid_block in *. eapply Plt_Ple_trans; eauto. + - i. eapply mi_perm_inv; eauto. rewrite unchanged_on_perm; eauto. + Qed. + + Lemma genv_alloc_global_flat_inj + F V (CF: has_comp F) + (ge: Genv.t F V) + m + (INJ: Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m) + ida gda m_c + (ALLOC1 : Genv.alloc_global ge m (ida, gda) = Some m_c) + : + Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m_c. + Proof. + eapply mem_unchanged_on_inject. eauto. eapply Genv.alloc_global_unchanged; eauto. + instantiate (1:= fun b _ => Plt b (Mem.nextblock m)). i. + unfold Mem.flat_inj in H. des_ifs. + Qed. + + Lemma genv_alloc_globals_flat_inj + F V (CF: has_comp F) + (ge: Genv.t F V) (gds: list (ident * globdef F V)) + m + (INJ: Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m) + m_c + (ALLOC: Genv.alloc_globals ge m gds = Some m_c) + : + Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m_c. + Proof. + eapply mem_unchanged_on_inject. eauto. eapply Genv.alloc_globals_unchanged; eauto. + instantiate (1:= fun b _ => Plt b (Mem.nextblock m)). i. + unfold Mem.flat_inj in H. des_ifs. + Qed. + + Lemma genv_init_mem_inj + p_a btr p_c + (NR: list_norepet (map fst (AST.prog_defs p_a))) + (P_C: p_c = gen_program btr p_a) + m_a + (MEM_A: Genv.init_mem p_a = Some m_a) + m_c + (MEM_C: Genv.init_mem p_c = Some m_c) + : + let k := (Mem.flat_inj (Mem.nextblock m_a)) in + Mem.inject k m_a m_c. + Proof. + subst. hexploit gen_program_split_init_mem; eauto. intros ALLOC. + ss. hexploit Genv.initmem_inject. eapply MEM_A. intros INJ1. + eapply genv_alloc_globals_flat_inj; eauto. + Qed. + + Lemma genv_find_symbol_add_globals_map_inv + F0 V0 F1 V1 + id b l + (ge0: Genv.t F0 V0) (ge1: Genv.t F1 V1) + (NB: (Genv.genv_next ge0) = (Genv.genv_next ge1)) + f f' + (FUN: f' = fun '(id, x) => (id, f (id, x))) + (FIND: Genv.find_symbol (Genv.add_globals ge1 (map f' l)) id = Some b) + gd + (IN: In (id, gd) (map f' l)) + : + (Genv.find_symbol (Genv.add_globals ge0 l) id = Some b). + Proof. + subst f'. revert_until l. induction l; i; ss. + destruct a as (id0 & gd0); ss. des. + { clarify. destruct (in_dec Pos.eq_dec id (map fst l)). + { eapply list_in_map_inv in i. des. destruct x as (id' & gd'). ss. subst id'. eapply IHl; eauto. + - unfold Genv.genv_next, Genv.add_global. rewrite NB. auto. + - eapply (in_map (fun '(id0, x) => (id0, f (id0, x)))) in i0. eapply i0. + } + { clear IHl. rewrite genv_find_symbol_add_globals_other. + - rewrite genv_find_symbol_add_globals_other in FIND. + + unfold Genv.find_symbol, Genv.add_global in *. ss. rewrite PTree.gss in *. rewrite NB. auto. + + apply Forall_forall. i. des_ifs. ii. subst i. apply n. + apply (in_map fst) in H. ss. rewrite map_map in H. + assert ((fun x : ident * globdef F0 V0 => fst (let '(id, x0) := x in (id, f (id, x0)))) = fst). + { extensionalities. des_ifs. } + rewrite H0 in H. auto. + - apply Forall_forall. i. des_ifs. ii. subst i. apply n. apply (in_map fst) in H. ss. + } + } + { eapply IHl; eauto. unfold Genv.genv_next, Genv.add_global. rewrite NB. auto. } + Qed. + + Lemma genv_find_symbol_add_globals_gt_block + F V gds (ge: Genv.t F V) id b + (FIND: Genv.find_symbol (Genv.add_globals ge gds) id = Some b) + (IN: In id (map fst gds)) + : + (Genv.genv_next ge <= b)%positive. + Proof. + revert_until gds. induction gds; i; ss. destruct a as (ida & gda); ss; des; clarify. + - destruct (in_dec Pos.eq_dec id (map fst gds)). + + specialize (IHgds _ id _ FIND i). ss. lia. + + clear IHgds. rewrite genv_find_symbol_add_globals_other in FIND. + * unfold Genv.find_symbol, Genv.add_global in FIND. ss. rewrite PTree.gss in FIND. clarify. lia. + * apply Forall_forall. i. destruct x as (idx & gdx). ii. subst. apply n. apply (in_map fst) in H. ss. + - specialize (IHgds _ id _ FIND IN). ss. lia. + Qed. + + Lemma genv_advance_next_eq_len + F1 V1 F2 V2 + (gds1: list (ident * globdef F1 V1)) + (gds2: list (ident * globdef F2 V2)) + (LEN: length gds1 = length gds2) + x + : + Genv.advance_next gds1 x = Genv.advance_next gds2 x. + Proof. + revert_until gds1. induction gds1; i; ss. + { destruct gds2; ss. } + destruct gds2; ss. apply IHgds1; eauto. + Qed. + + Lemma genv_find_symbol_gen_program_cases + p btr + (WFP: wf_program p) + id b + (FIND: Genv.find_symbol (Genv.globalenv (gen_program btr p)) id = Some b) + : + ((forall i, (In i (map fst (AST.prog_defs p))) -> (i < id)%positive) /\ + (Genv.genv_next (Genv.globalenv p) <= b)%positive) \/ + (In id (map fst (AST.prog_defs p)) /\ (b < Genv.genv_next (Genv.globalenv p))%positive). + Proof. + unfold gen_program, Genv.globalenv in *. ss. + set (Genv.add_globals (Genv.empty_genv Asm.fundef unit (AST.prog_public p) (AST.prog_pol p)) (AST.prog_defs p)) as ge_a in *. + unfold gen_prog_defs in FIND. rewrite Genv.add_globals_app in FIND. + set (AST.prog_defs p) as gds in *. + destruct (Forall_Exists_dec _ (pos_neq_dec id) (map fst (map snd (PTree.elements (gen_counter_defs (next_id gds) gds))))). + - right. rewrite genv_find_symbol_add_globals_other in FIND. + 2:{ rewrite Forall_map in f. eapply Forall_impl; eauto. ss. i. des_ifs. } + set ({| + prog_defs := (map + (fun '(id, gd) => + (id, + gen_progdef ge_a (get_id_tr btr id) gd + (gen_counter_defs (next_id gds) gds) ! id + (gen_params + (next_id (map snd (PTree.elements (gen_counter_defs (next_id gds) gds)))) + gds) ! id)) gds); + prog_public := AST.prog_public p; + prog_main := AST.prog_main p; + prog_pol := AST.prog_pol p; + prog_types := []; + prog_comp_env := PTree.empty composite; + prog_comp_env_eq := (fun (_ : bundle_trace) (_ : Asm.program) => Backtranslation.gen_program_obligation_1) btr p + |}) as p_t. + (* hexploit Genv.find_symbol_find_def_inversion. *) + (* { instantiate (3:=p_t). unfold Genv.globalenv. subst p_t. ss. eapply FIND. } *) + hexploit Genv.find_symbol_inversion. + { instantiate (3:=p_t). unfold Genv.globalenv. subst p_t. ss. eapply FIND. } + intros IN. subst p_t. unfold prog_defs_names in IN. ss. apply list_in_map_inv in IN. + des. destruct x. ss; clarify. rename i into id, g into gd. + hexploit genv_find_symbol_add_globals_map_inv. 3: eapply FIND. + { instantiate (1:=(Genv.empty_genv Asm.fundef unit (AST.prog_public p) (AST.prog_pol p))). + ss. + } + { instantiate (1:= fun '(id0, gd) => + gen_progdef ge_a (get_id_tr btr id0) gd (gen_counter_defs (next_id gds) gds) ! id0 + (gen_params (next_id (map snd (PTree.elements (gen_counter_defs (next_id gds) gds)))) gds) + ! id0). ss. + } + { eauto. } + intros FIND2. split. + { apply (in_map fst) in IN0; ss. rewrite map_map in IN0. ss. + assert (EQ: ((fun x : ident * globdef Asm.fundef unit => + fst + (let + '(id, gd) := x in + (id, + gen_progdef ge_a (get_id_tr btr id) gd + (gen_counter_defs (next_id gds) gds) ! id + (gen_params + (next_id (map snd (PTree.elements (gen_counter_defs (next_id gds) gds)))) + gds) ! id)))) = fst). + { extensionalities. des_ifs. } + setoid_rewrite EQ in IN0. auto. + } + { hexploit Genv.genv_symb_range. eapply FIND2. ss. } + - left. apply Exists_exists in e. des. apply Classical_Prop.NNPP in e0. subst x. + hexploit list_in_map_inv. eapply e. intros. des. destruct x. ss; subst. + rename i into id, g into gd. + hexploit list_in_map_inv. eapply H0. intros. des. destruct x, p1. ss; clarify. + rename i into cnt, p0 into id, g into gd. + apply PTree.elements_complete in H1. apply gen_counter_defs_lt in H1. split. + + i. apply list_in_map_inv in H. des. destruct x; ss; clarify. apply next_id_lt in H2. lia. + + etransitivity; cycle 1. + { eapply genv_find_symbol_add_globals_gt_block. eapply FIND. ss. } + { subst ge_a. rewrite ! Genv.genv_next_add_globals. ss. + apply Pos.le_partorder. apply genv_advance_next_eq_len. + apply map_length. + } + Qed. + + Definition max_id0 {A} (l: list (ident * A)) i: ident := + (fold_left (fun x '(i, _) => if (x exists i2, In i2 (map fst l2) /\ (i1 < i2)%positive) + a b + (AB: (a <= b)%positive) + : + (max_id0 (l1 ++ l2) a <= max_id0 l2 b)%positive. + Proof. + revert_until l1. induction l1; i; ss. + { apply max_id0_ge; auto. } + destruct a as (id & a); ss. des_ifs; auto. + destruct (Pos.ltb_spec a0 id); ss. clear Heq. hexploit GT. left; auto. i; des. + destruct (Pos.ltb_spec i2 b); ss. + { apply IHl1. 2: lia. i. eapply GT. auto. } + rewrite (max_id0_base _ _ _ _ H0); auto. apply IHl1; auto. lia. + Qed. + + Lemma star_state_behaves_cut + p s0 tr + (CUT: exists s1, star step1 (globalenv p) s0 E0 s1 /\ + (exists s2 beh, star step1 (globalenv p) s1 tr s2 /\ + state_behaves (semantics1 p) s2 beh)) + : + exists s2 beh, star step1 (globalenv p) s0 tr s2 /\ state_behaves (semantics1 p) s2 beh. + Proof. + des. exists s2, beh. split; auto. eapply star_trans. 2: eauto. eauto. ss. + Qed. + +End PROOFINIT. + + + +Definition asm_program_does_prefix (p: Asm.program) (t: trace) := + semantics_has_initial_trace_prefix (Asm.semantics p) t. +Definition clight_program_does_prefix (p: Clight.program) (t: trace) := + semantics_has_initial_trace_prefix (Clight.semantics1 p) t. + +Definition asm_program_is_wf (p: Asm.program) := + (wf_program p) /\ + (wf_program_public p) /\ + (exists b, Genv.find_symbol (Genv.globalenv p) (AST.prog_main p) = Some b /\ + (exists f, Genv.find_funct_ptr (Genv.globalenv p) b = Some (AST.Internal f) /\ + (fn_sig f = signature_main))) /\ + (exists m0, Genv.init_mem p = Some m0). + + + +Section PROOF. + + Lemma step_fix_fix + p s tr s' + : + star (Asm.step (comp_of_main p)) (Genv.globalenv p) s tr s' + -> star (step_fix (comp_of_main p)) (Genv.globalenv p) s tr s'. + Proof. + (* TODO: FIXME *) + Admitted. + + Hypothesis EFO: external_functions_observable. + Hypothesis IAO: inline_assembly_observable. + + Lemma asm_to_clight + (p: Asm.program) + (WFP: wf_program p) + (WFPP: wf_program_public p) + (WFMAIN: wf_main p) + (WFMAINSIG: wf_main_sig p) + (WFINIT: exists (s : Asm.state), Asm.initial_state p s) + : + forall tr, + (Z.of_nat (length tr) < Int64.modulus) -> + asm_program_does_prefix p tr -> + exists btr, + clight_program_does_prefix (gen_program btr p) tr /\ + unbundle_trace btr = tr. + Proof. + i. rename H into BOUND, H0 into H. + eapply semantics_has_initial_trace_prefix_implies_cut in H. + 2:{ apply sd_traces. apply semantics_determinate. } + inv H; cycle 1. + { exfalso. ss. des. eapply H0. eapply WFINIT. } + clear WFINIT. ss. des. hexploit ir_has_initial_state; eauto. intros (ist & IR_INIT). + hexploit match_state_initial_state; eauto. intros (m0 & j & INIT_MEM_A & MS_I). + hexploit asm_to_ir. + { eapply wf_program_wf_ge; eauto. } + { eapply wf_asm_initial_state; eauto. } + { eapply step_fix_fix. eauto. } + { eapply MS_I. } + intros (btr & ist' & UTR & ISTAR). esplits. 2: eauto. + eapply semantics_has_initial_trace_cut_implies_prefix. + hexploit exists_initial_state; eauto. instantiate (1:=btr). + intros (f_cur & m_c & INIT_C & F_MAIN). + econs 1; ss. eapply INIT_C. eapply star_state_behaves_cut. + eexists. split. + { econs 2. 2: econs 1. 2: traceEq. eapply step_internal_function. + instantiate (3:=empty_env). instantiate (2:=@PTree.empty _). instantiate (1:=m_c). + des. econs; ss. all: try rewrite F_MAIN; try rewrite F_MAIN0; try rewrite F_MAIN1; ss. + econs. econs. econs. + } + clear dependent s. clear dependent s'. clear dependent m0. clear beh' j. + inv IR_INIT. clarify. des. inv INIT_C. rewrite gen_program_prog_main_eq in *. + remember (AST.prog_main p) as id_cur. clear Heqid_cur. + hexploit gen_program_match_find_def; eauto. intros MFD. + hexploit Genv.find_invert_symbol. eapply H. intros INV_A. + dup H0. rewrite Genv.find_funct_ptr_iff in H2. specialize (MFD _ _ _ H2 INV_A). + des_ifs. rename Heq into CNT_CUR. rename Heq0 into PAR_CUR. + assert (b = cur). + { eapply gen_program_symbs_find in H; eauto. ss. + subst ge0. setoid_rewrite H5 in H. clarify. ss. + } + subst b. ss. rewrite <- Genv.find_funct_ptr_iff in MFD. + assert (f_cur = (gen_function (Genv.globalenv p) i l (get_id_tr btr id_cur) f)). + { subst ge0. setoid_rewrite H6 in MFD. clarify. } + clear MFD. + hexploit gen_program_match_genv; eauto. instantiate (1:=btr). intros MGENV. + + hexploit ir_to_clight. + { eapply wf_program_wf_ge; eauto. } + 4: eapply ISTAR. + { hexploit bundle_trace_bounded; auto. apply ISTAR. clear - BOUND. i. lia. } + { instantiate (1:=State f_cur (fn_body f_cur) Kstop empty_env (PTree.empty val) m_c). + instantiate (1:=id_cur). + instantiate (1:=(get_cnt_ids (gen_counter_defs (next_id (AST.prog_defs p)) (AST.prog_defs p)))). + instantiate (1:= globalenv (gen_program btr p)). ss. splits. + - unfold wf_counters. split. + { eapply gen_counter_defs_cnt_ids_inj; eauto. } + i. assert (PDM: (prog_defmap p) ! id = Some gd). + { rewrite Genv.find_def_symbol. esplits; eauto. } + hexploit gen_counter_defs_inv; eauto. eapply in_prog_defmap; eauto. intros GETCNT. + esplits. + { unfold get_cnt_ids. rewrite PTree.gmap. rewrite GETCNT. ss. } + set (id + next_id (AST.prog_defs p))%positive as id_cnt. + unfold wf_counter. splits. + { ss. assert (NIN: ~ In id_cnt (Genv.genv_public (Genv.globalenv (gen_program btr p)))). + { ii. destruct MGENV as ((MS0 & MS1 & MS2) & EQP). + replace (Genv.genv_public (Genv.globalenv (gen_program btr p))) with + (AST.prog_public p) in H10. + 2:{ rewrite Genv.globalenv_public. ss. } + apply WFPP in H10. apply list_in_map_inv in H10. des. destruct x; ss; clarify. + apply next_id_lt in H11. lia. + } + unfold Genv.public_symbol. des_ifs. + eapply (pred_dec_false (in_dec ident_eq _ _) true false) in NIN. des_ifs. + } + ss. assert (PDM_C: (prog_defmap (gen_program btr p)) ! id_cnt = Some (gen_counter (comp_of gd))). + { apply prog_defmap_norepet. apply gen_program_list_norepet; auto. + unfold gen_program. ss. unfold gen_prog_defs. apply in_or_app. right. + apply PTree.elements_correct in GETCNT. apply (in_map snd) in GETCNT. ss. + } + apply Genv.find_def_symbol in PDM_C. des. + hexploit Genv.init_mem_characterization_gen. eapply H4. + intros GI. specialize (GI _ _ PDM_C0). ss. des. + specialize (GI1 eq_refl). specialize (GI2 eq_refl). des. + esplits; eauto. + unfold Mem.valid_access. splits; auto. 2: apply Z.divide_0_r. + eapply Mem.loadbytes_can_access_block_inj; eauto. + - esplits; eauto. econs. + - unfold wf_c_stmt. i. subst f_cur. ss. rewrite CNT_CUR in H8. clarify. + replace (comp_of (gen_function (Genv.globalenv p) cnt [] (get_id_tr btr id_cur) f)) with + (Asm.fn_comp f). + 2:{ ss. } + apply match_symbs_code_bundle_trace. apply MGENV. + - ii. des_ifs. + - unfold not_global_blks. unfold empty_env. ss. unfold blocks_of_env2, blocks_of_env. ss. + - unfold wf_c_nb. ss. erewrite Genv.init_mem_genv_next. reflexivity. auto. + } + { instantiate (1:= gen_params (next_id (map snd (PTree.elements (gen_counter_defs (next_id (AST.prog_defs p)) (AST.prog_defs p))))) (AST.prog_defs p)). + ss. splits. + - auto. + - assert (INCR: inject_incr (meminj_public (Genv.globalenv p)) (Mem.flat_inj (Mem.nextblock m0))). + { clear - H1. ii. unfold meminj_public in H. des_ifs. ss. + apply Genv.invert_find_symbol in Heq. unfold Genv.find_symbol in Heq. + apply Genv.genv_symb_range in Heq. apply Genv.init_mem_genv_next in H1. + unfold Mem.flat_inj. rewrite H1 in Heq. des_ifs. + } + unfold match_mem. splits; eauto. + + eapply genv_init_mem_inj; eauto. + + clear - INCR. ii. unfold inject_incr in INCR. + destruct (meminj_public (Genv.globalenv p) b) eqn:CASES; auto. + exfalso. destruct p0. specialize (INCR _ _ _ CASES). unfold Mem.flat_inj in INCR. + des_ifs. unfold Plt in *. lia. + - unfold match_cur_fun. ss. splits; ss. eauto. + - eapply gen_program_match_find_def; eauto. + - econs; auto. + - unfold match_params. splits. + + apply gen_params_wf. + + ii. hexploit in_gds_exists_params. 2: eauto. + { setoid_rewrite Genv.find_def_symbol. esplits; eauto. + rewrite <- Genv.find_funct_ptr_iff. eauto. + } + i. des. rewrite H10 in H11. clarify. + + ii. ss. hexploit Genv.find_symbol_inversion. apply H8. intros INDEF. + apply list_in_map_inv in H10. des. destruct x; ss; clarify. + hexploit gen_params_le. apply H9. apply H11. intros GT. + clear - WFP INDEF GT. unfold gen_program, prog_defs_names in INDEF. ss. + apply list_in_map_inv in INDEF. des. destruct x; ss; clarify. + apply next_id_lt in INDEF0. unfold gen_prog_defs in INDEF0. + assert (MAX: (max_id + (map + (fun '(id, gd) => + (id, + gen_progdef (Genv.globalenv p) (get_id_tr btr id) gd + (gen_counter_defs (next_id (AST.prog_defs p)) (AST.prog_defs p)) ! id + (gen_params + (next_id + (map snd + (PTree.elements + (gen_counter_defs (next_id (AST.prog_defs p)) (AST.prog_defs p))))) + (AST.prog_defs p)) ! id)) (AST.prog_defs p) ++ + map snd + (PTree.elements (gen_counter_defs (next_id (AST.prog_defs p)) (AST.prog_defs p)))) <= + max_id (map snd + (PTree.elements (gen_counter_defs (next_id (AST.prog_defs p)) (AST.prog_defs p)))))%positive). + { apply max_id0_app. 2: lia. clear - WFP. i. rewrite map_map in H. + apply list_in_map_inv in H. des. destruct x; ss; clarify. + rewrite map_map. + hexploit gen_counter_defs_inv; eauto. intros. + apply PTree.elements_correct in H. + apply (in_map (fun x : positive * (ident * globdef fundef type) => fst (snd x))) in H. + ss. eexists. split. apply H. lia. + } + rewrite next_id_is_succ_max_id in INDEF0, GT. lia. + - ii. setoid_rewrite PTree.gmap in H8. unfold option_map in H8. des_ifs. + hexploit gen_counter_defs_lt; eauto. intros LT. + unfold Mem.flat_inj in H10. des_ifs. erewrite <- Genv.init_mem_genv_next in p0; eauto. + hexploit Genv.find_symbol_inversion. apply H9. intros INDEFS. + ss. hexploit genv_find_symbol_gen_program_cases. eauto. eapply H9. i. des. + + unfold Plt in p0. lia. + + clear - LT H3. apply list_in_map_inv in H3. des. destruct x; ss; clarify. + hexploit next_id_lt; eauto. i. lia. + } + intros (cst' & STAR_C). hexploit state_behaves_exists. intros (beh2 & BEH2). + esplits; eauto. + Qed. + +End PROOF. + +Section BT. + + Hypothesis EFO: external_functions_observable. + Hypothesis IAO: inline_assembly_observable. + + Theorem backtranslation_proof + (p: Asm.program) + (WF: asm_program_is_wf p) + : + forall tr, + (Z.of_nat (length tr) < Int64.modulus) -> + asm_program_does_prefix p tr -> + exists p_c, + clight_program_does_prefix p_c tr. + Proof. + unfold asm_program_is_wf in WF. des. i. + hexploit asm_to_clight; eauto. + { rr. esplits; eauto. } + { rr. i. rewrite WF1 in H1. clarify. } + { eexists. econs; eauto. } + i. des. eauto. + Qed. + +End BT. diff --git a/security/BtBasics.v b/security/BtBasics.v new file mode 100644 index 0000000000..007275ddf4 --- /dev/null +++ b/security/BtBasics.v @@ -0,0 +1,260 @@ +Require Import String. +Require Import Coqlib Maps Errors Integers Values Memory Globalenvs. +Require Import AST Linking Smallstep Events Behaviors. + +Require Import Split. + + +Section GENV. + + Context {F: Type}. + Context {V: Type}. + + Lemma genv_def_to_some_ident + (p: AST.program F V) + (NR: list_norepet (prog_defs_names p)) + ge + (GE: ge = Genv.globalenv p) + b gd + (DEF: Genv.find_def ge b = Some gd) + : + exists id b', Genv.find_symbol ge id = Some b' /\ Genv.find_def ge b' = Some gd. + Proof. + subst ge. exploit Genv.find_def_inversion; eauto. intros [id IN]. + assert (GET: (prog_defmap p) ! id = Some gd). + { unfold prog_defmap. unfold prog_defs_names in NR. apply PTree_Properties.of_list_norepet; auto. } + apply Genv.find_def_symbol in GET. destruct GET as [b' [FINDSYM FINDDEF]]. eauto. + Qed. + + Lemma genv_find_def_add_global_spec + (ge: Genv.t F V) id gd + (NEW: Genv.find_symbol ge id = None) + b gd' + (ADD: Genv.find_def (Genv.add_global ge (id, gd)) b = Some gd') + : + ((b = (Genv.genv_next ge)) /\ (gd' = gd)) \/ + ((b <> (Genv.genv_next ge)) /\ (Genv.find_def ge b = Some gd')). + Proof. + destruct (Pos.eqb_spec b (Genv.genv_next ge)). + - left; split; auto. + unfold Genv.find_def, Genv.add_global in ADD. subst; simpl in *. + rewrite PTree.gss in ADD. inversion ADD; auto. + - right; split; auto. + unfold Genv.find_def, Genv.add_global in ADD. simpl in *. + rewrite PTree.gso in ADD; auto. + Qed. + + Lemma genv_def_to_ident + (p: AST.program F V) + (NR: list_norepet (prog_defs_names p)) + ge + (GE: ge = Genv.globalenv p) + b gd + (DEF: Genv.find_def ge b = Some gd) + : + exists id, Genv.invert_symbol ge b = Some id. + Proof. + subst ge. unfold Genv.globalenv, Genv.add_globals, prog_defs_names in *. + destruct p; simpl in *. clear - NR DEF. + remember (Genv.empty_genv F V prog_public prog_pol) as ge. + replace (fold_left (Genv.add_global (V:=V)) prog_defs ge) with + (fold_right (fun ig g => Genv.add_global g ig) ge (rev prog_defs)) in *. + 2:{ rewrite fold_left_rev_right. f_equal. } + remember (rev prog_defs) as rev_prog_defs. + assert (RNR: list_norepet (map fst rev_prog_defs)). + { subst. rewrite map_rev. apply list_norepet_rev; auto. } + clear prog_defs NR Heqrev_prog_defs. subst ge. + revert prog_public prog_pol b gd DEF RNR. + induction rev_prog_defs; intros. + { unfold Genv.find_def in DEF. simpl in DEF. rewrite PTree.gempty in DEF. congruence. } + destruct a as [id0 gd0]. + simpl in *. specialize (IHrev_prog_defs prog_public prog_pol). + remember (fold_right (fun (ig : ident * globdef F V) (g : Genv.t F V) => Genv.add_global g ig) (Genv.empty_genv F V prog_public prog_pol) rev_prog_defs) as ge. + assert (GE: ge = Genv.globalenv (AST.mkprogram (rev rev_prog_defs) prog_public id0 prog_pol)). + { subst ge. unfold Genv.globalenv. unfold Genv.add_globals. simpl. + rewrite <- fold_left_rev_right. rewrite rev_involutive. auto. } + apply genv_find_def_add_global_spec in DEF. + { destruct DEF as [[BLK GD] | [BLK GD]]. + - subst b gd0. exists id0. + apply Genv.find_invert_symbol. unfold Genv.find_symbol, Genv.add_global; simpl. + rewrite PTree.gss. auto. + - inversion RNR; clear RNR. subst hd tl. specialize (IHrev_prog_defs _ _ GD H2). + destruct IHrev_prog_defs as [id' INV]. exists id'. + apply Genv.find_invert_symbol. unfold Genv.find_symbol, Genv.add_global; simpl. + rewrite PTree.gso. apply Genv.invert_find_symbol in INV. auto. + clear - H1 Heqge INV GE. apply Genv.invert_find_symbol in INV. + rewrite GE in INV. apply Genv.find_symbol_inversion in INV. + unfold prog_defs_names in INV. simpl in INV. + rewrite map_rev in INV. apply in_rev in INV. intros CONTRA. subst id'. auto. + } + { destruct (Genv.find_symbol ge id0) eqn:CASE; auto. exfalso. + rewrite GE in CASE. apply Genv.find_symbol_inversion in CASE. + unfold prog_defs_names in CASE. simpl in CASE. rewrite map_rev in CASE. apply in_rev in CASE. + clear - CASE RNR. inversion RNR. auto. + } + Qed. + +End GENV. + + +Section MEM. + + (* f doesn't map anything to [b], e.g. the counter and function parameters *) + Definition meminj_notmap (f: meminj) b := forall b0 ofs0, ~ (f b0 = Some (b, ofs0)). + + Lemma loc_out_of_reach_unchanged_on_content: + forall f b ofs m1 m1' m2' + (NOTMAP: meminj_notmap f b), + Mem.perm m1' b ofs Cur Readable -> + Mem.unchanged_on (loc_out_of_reach f m1) m1' m2' -> + ZMap.get ofs (Mem.mem_contents m2') !! b = ZMap.get ofs (Mem.mem_contents m1') !! b. + Proof. + intros. destruct H0. apply unchanged_on_contents; eauto. + unfold loc_out_of_reach. intros. now specialize (NOTMAP _ _ H0). + Qed. + + Lemma loc_out_of_reach_unchanged_on_perm: + forall f b ofs m1 m1' m2' k p + (NOTMAP: meminj_notmap f b), + Mem.perm m1' b ofs k p -> + Mem.unchanged_on (loc_out_of_reach f m1) m1' m2' -> + Mem.perm m2' b ofs k p. + Proof. + intros. destruct H0. apply unchanged_on_perm; eauto. + unfold loc_out_of_reach. intros. now specialize (NOTMAP _ _ H0). + eapply Mem.perm_valid_block; eauto. + Qed. + + Lemma inject_separated_notmap + f f' m m' b + (NM: meminj_notmap f b) + (VALID: Mem.valid_block m' b) + (* (INJ: Mem.inject f m m') *) + (INCR: inject_incr f f') + (SEP: inject_separated f f' m m') + : + meminj_notmap f' b. + Proof. + unfold meminj_notmap, inject_incr, inject_separated in *. + intros. intros CONTRA. specialize (NM b0 ofs0). destruct (f b0) eqn:FB. + { destruct p. specialize (INCR _ _ _ FB). rewrite CONTRA in INCR. inversion INCR; clear INCR; subst. congruence. } + specialize (SEP _ _ _ FB CONTRA). destruct SEP as [NV1 NV2]. congruence. + Qed. + +End MEM. + +Section HASINIT. + Import Smallstep. + + Variant semantics_has_initial_trace_cut (L: Smallstep.semantics) (t: trace) : Prop := + | semantics_cut_runs : + forall s, (initial_state L s) -> (exists s' beh', ((star (step L) (globalenv L)) s t s') /\ (state_behaves L s' beh')) -> semantics_has_initial_trace_cut _ t + | semantics_cut_goes_initially_wrong : (forall s : state L, ~ initial_state L s) -> (t = nil) -> semantics_has_initial_trace_cut _ t. + + Definition semantics_has_initial_trace_prefix (L: Smallstep.semantics) (t: trace): Prop := + exists beh, (program_behaves L beh) /\ (behavior_prefix t beh). + + Lemma semantics_has_initial_trace_cut_implies_prefix + L t + (HAS: semantics_has_initial_trace_cut L t) + : + semantics_has_initial_trace_prefix L t. + Proof. + inversion HAS. + - destruct H0 as (s' & beh' & STAR & BEH). red. exists (behavior_app t beh'). split. + + econstructor 1. eauto. eapply state_behaves_app; eauto. + + red. eauto. + - subst. red. eexists. split. + + econstructor 2. eauto. + + red. exists (Goes_wrong E0). reflexivity. + Qed. + + Lemma state_behaves_app_inv_one + L s1 beh t beh' + (SE: single_events L) + (BEH: state_behaves L s1 beh) + (APP: beh = behavior_app t beh') + (ONE: (Datatypes.length t = 1)%nat) + : + exists s2, (Star L s1 t s2) /\ (state_behaves L s2 beh'). + Proof. + destruct t; simpl in *. congruence. destruct t; simpl in *. 2: congruence. clear ONE. + inv BEH. + - destruct beh'; simpl in *; try congruence. inv H1. + remember (e :: t0) as tr. revert e t0 i SE Heqtr H0. induction H; intros. + { inv Heqtr. } + subst. assert (SE0: single_events L) by auto. specialize (SE _ _ _ H). inv SE. + + destruct t1; simpl in *. congruence. destruct t1; simpl in *. 2: congruence. + inv Heqtr. exists s2. split. econstructor 2. eauto. econstructor 1. traceEq. + econstructor; eauto. + + destruct t1; simpl in *. 2: lia. clear H3. + specialize (IHstar _ _ _ SE0 Heqtr H2). destruct IHstar as (s2' & STAR & TERM). + exists s2'. split; auto. econstructor 2. eauto. eauto. traceEq. + - destruct beh'; simpl in *; try congruence. inv H1. + remember (e :: t0) as tr. revert e t0 SE Heqtr H0. induction H; intros. + { inv Heqtr. } + subst. assert (SE0: single_events L) by auto. specialize (SE _ _ _ H). inv SE. + + destruct t1; simpl in *. congruence. destruct t1; simpl in *. 2: congruence. + inv Heqtr. exists s2. split. econstructor 2. eauto. econstructor 1. traceEq. + econstructor; eauto. + + destruct t1; simpl in *. 2: lia. clear H3. + specialize (IHstar _ _ SE0 Heqtr H2). destruct IHstar as (s2' & STAR & TERM). + exists s2'. split; auto. econstructor 2. eauto. eauto. traceEq. + - destruct beh'; simpl in *; try congruence. inv H0. + inv H. revert e t SE T H2 H4 H0. induction H1; intros. congruence. + subst. assert (SE0: single_events L) by auto. specialize (SE _ _ _ H). inv SE. + + destruct t1; simpl in *. congruence. destruct t1; simpl in *. 2: congruence. + clear H5. inv H3. destruct t2. + * exists s3. split. econstructor 2. eauto. eauto. traceEq. + econstructor. auto. + * exists s2. split. econstructor 2. eauto. econstructor 1. traceEq. + econstructor. econstructor. eauto. intros F. inv F. auto. + + destruct t1; simpl in *. 2: lia. clear H5. + specialize (IHstar _ _ SE0 _ H2 H4 H3). destruct IHstar as (s2' & STAR & TERM). + exists s2'. split; auto. econstructor 2. eauto. eauto. traceEq. + - destruct beh'; simpl in *; try congruence. inv H2. + remember (e :: t0) as tr. revert e t0 SE Heqtr H0 H1. induction H; intros. + { inv Heqtr. } + subst. assert (SE0: single_events L) by auto. specialize (SE _ _ _ H). inv SE. + + destruct t1; simpl in *. congruence. destruct t1; simpl in *. 2: congruence. + clear H4. inv Heqtr. exists s2. split. econstructor 2. eauto. econstructor 1. traceEq. + econstructor; eauto. + + destruct t1; simpl in *. 2: lia. clear H4. + specialize (IHstar _ _ SE0 Heqtr H2 H3). destruct IHstar as (s2' & STAR & TERM). + exists s2'. split; auto. econstructor 2. eauto. eauto. traceEq. + Qed. + + Lemma state_behaves_app_inv + L s1 beh t beh' + (SE: single_events L) + (BEH: state_behaves L s1 beh) + (APP: beh = behavior_app t beh') + : + exists s2, (Star L s1 t s2) /\ (state_behaves L s2 beh'). + Proof. + revert s1 beh beh' SE BEH APP. induction t; intros. + { rewrite behavior_app_E0 in APP. subst beh'. exists s1. split; auto. econstructor 1. } + replace (a :: t) with ((a :: E0) ++ t) in *. + 2:{ simpl. auto. } + rewrite behavior_app_assoc in APP. exploit state_behaves_app_inv_one. + 3: eapply APP. all: eauto. + intros (s2 & STAR & NEXTBEH). specialize (IHt _ _ beh' SE NEXTBEH). + exploit IHt; auto. intros (s3 & STAR2 & TERM). + exists s3. split; auto. eapply star_trans; eauto. + Qed. + + Lemma semantics_has_initial_trace_prefix_implies_cut + L t + (SE: single_events L) + (HAS: semantics_has_initial_trace_prefix L t) + : + semantics_has_initial_trace_cut L t. + Proof. + inversion HAS. destruct H as [BEH (beh' & APP)]. subst x. inversion BEH; clear BEH. + - subst beh. econstructor 1. eauto. exploit state_behaves_app_inv; eauto. + intros (s2 & STAR & BEH). exists s2, beh'. auto. + - econstructor 2. auto. destruct beh'; simpl in *; try congruence. inv H. + symmetry in H2; apply Eapp_E0_inv in H2. destruct H2; auto. + Qed. + +End HASINIT. diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v new file mode 100644 index 0000000000..1c7dba6088 --- /dev/null +++ b/security/BtInfoAsm.v @@ -0,0 +1,2416 @@ +Require Import String. +Require Import Coqlib Maps Errors Integers Values Memory Globalenvs. +Require Import AST Linking Smallstep Events Behaviors. + +Require Import Split. + +Require Import riscV.Machregs. +Require Import riscV.Asm. +Require Import Complements. + +Require Import Tactics. +Require Import MemoryWeak MemoryDelta. +Require Import BtBasics. + + + +Section AUX. + + Lemma val_load_result_idem chunk v: + Val.load_result chunk (Val.load_result chunk v) = Val.load_result chunk v. + Proof. + destruct chunk, v; ss. + all: try (rewrite Int.sign_ext_idem; auto; lia). + all: try (rewrite Int.zero_ext_idem; auto; lia). + all: des_ifs. + Qed. + + Lemma extcall_cases + ef ge m args + (ECC: external_call_conds ef ge m args) + tr rv m' + (ECALL: external_call ef ge args m tr rv m') + : + (external_call_unknowns ef ge m args) \/ + (external_call_known_observables ef ge m args tr rv m') \/ + (external_call_known_silents ef ge m args tr rv m'). + Proof. + destruct ef; ss; auto. des_ifs; auto. des_ifs; auto. + - destruct tr; ss; eauto. right; left. esplits; eauto. ss. + - destruct tr; ss; eauto. right; left. esplits; eauto. ss. + - inv ECALL. right; right. esplits; eauto. econs; eauto. + - inv ECALL. right; right. esplits; eauto. econs; eauto. + right; right. esplits; eauto. econs; eauto. + - inv ECALL. right; right. esplits; eauto. econs; eauto. + - destruct tr; ss; eauto. right; left. esplits; eauto. ss. + - destruct tr; ss; eauto. right; left. esplits; eauto. ss. + - inv ECALL. right; right. esplits; eauto. econs; eauto. + Qed. + +End AUX. + + + +Section BUNDLE. + + Variant bundle_event : Type := + (* generate a call code + other followup events; call-ext-ret *) + | Bundle_call (tr: trace) (id: ident) (args: list eventval) (sg: signature) + (d: mem_delta) + (* generate a return code; ret *) + | Bundle_return (tr: trace) (retv: eventval) + (d: mem_delta) + (* generate a builtin code; ext *) + | Bundle_builtin (tr: trace) (ef: external_function) (args: list eventval) + (d: mem_delta) + . + + Definition bundle_trace := list (ident * bundle_event). + + Definition unbundle_ev (be: (bundle_event)): trace := + match be with + | (Bundle_call tr _ _ _ _) + | (Bundle_return tr _ _) + | (Bundle_builtin tr _ _ _) => tr + end. + + Definition unbundle (be: (ident * bundle_event)): trace := unbundle_ev (snd be). + + Fixpoint unbundle_trace (btr: bundle_trace) : trace := + match btr with + | be :: tl => (unbundle be) ++ (unbundle_trace tl) + | nil => nil + end. + + Lemma unbundle_trace_cons + be btr + : + unbundle_trace (be :: btr) = (unbundle be) ++ (unbundle_trace btr). + Proof. simpl. auto. Qed. + + Lemma unbundle_trace_app + btr1 btr2 + : + unbundle_trace (btr1 ++ btr2) = (unbundle_trace btr1) ++ (unbundle_trace btr2). + Proof. + revert btr2. induction btr1; intros. + { simpl. auto. } + rewrite <- app_comm_cons. rewrite ! unbundle_trace_cons. rewrite <- app_assoc. f_equal. + eauto. + Qed. + + Inductive istar {genv state : Type} + (step : genv -> state -> (ident * bundle_event) -> state -> Prop) (ge : genv) : + state -> bundle_trace -> state -> Prop := + istar_refl : forall s : state, istar step ge s nil s + | istar_step : forall (s1 : state) ev (s2 : state) (t2 : bundle_trace) (s3 : state) (t : bundle_trace), + step ge s1 ev s2 -> istar step ge s2 t2 s3 -> t = ev :: t2 -> istar step ge s1 t s3. + + Lemma istar_trans + genv state (step: genv -> state -> _ -> state -> Prop) ge + s1 t1 s2 + (ISTAR1: istar step ge s1 t1 s2) + t2 s3 + (ISTAR2: istar step ge s2 t2 s3) + t + (TR: t = t1 ++ t2) + : + istar step ge s1 t s3. + Proof. + revert_until ISTAR1. induction ISTAR1; intros. + { simpl in *. subst; auto. } + subst. rewrite <- app_comm_cons. econstructor 2. eapply H. + { eapply IHISTAR1. eapply ISTAR2. eauto. } + auto. + Qed. + +End BUNDLE. + + +Section EVENT. + + Definition typ_to_eventval (ty: typ): eventval := + match ty with + | Tint => EVint Int.zero + | Tfloat => EVfloat Floats.Float.zero + | Tlong => EVlong Int64.zero + | Tsingle => EVsingle Floats.Float32.zero + | Tany32 => EVint Int.zero + | Tany64 => EVlong Int64.zero + end. + + Definition typ_to_eventvals (ty: list typ): list eventval := map typ_to_eventval ty. + + Inductive call_trace_cross {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> block -> list val -> list typ -> trace -> ident -> list eventval -> Prop := + | call_trace_cross_cross : forall (cp cp' : compartment) (b : block) (vargs : list val) (vl : list eventval) (ty : list typ) (i : ident) tr, + Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> + Genv.invert_symbol ge b = Some i -> eventval_list_match ge vl ty vargs -> + (tr = Event_call cp cp' i vl :: nil) -> + call_trace_cross ge cp cp' b vargs ty tr i vl. + + Inductive return_trace_cross {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> val -> rettype -> trace -> eventval -> Prop := + | return_trace_cross_cross : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype) tr, + Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> eventval_match ge res (proj_rettype ty) v -> + (tr = Event_return cp cp' res :: nil) -> + return_trace_cross ge cp cp' v ty tr res. + + (* external call *) + Definition senv_invert_symbol_total (ge: Senv.t) (b: block) : ident := + match Senv.invert_symbol ge b with + | Some id => id + | _ => xH + end. + + Definition val_to_eventval (ge: Senv.t) (v: val): eventval := + match v with + | Vundef => EVint Int.zero + | Vint n => EVint n + | Vlong n => EVlong n + | Vfloat n => EVfloat n + | Vsingle n => EVsingle n + | Vptr b o => let id := senv_invert_symbol_total ge b in EVptr_global id o + end. + + Definition vals_to_eventvals (ge: Senv.t) (vs: list val): list eventval := map (val_to_eventval ge) vs. + + Lemma eventval_match_val_to_eventval + ge ev ty v + (EVM: eventval_match ge ev ty v) + : + val_to_eventval ge v = ev. + Proof. + inv EVM; simpl; auto. + unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. + Qed. + + Lemma eventval_list_match_vals_to_eventvals + ge evs tys vs + (EVM: eventval_list_match ge evs tys vs) + : + vals_to_eventvals ge vs = evs. + Proof. + induction EVM; simpl; auto. + rewrite IHEVM. f_equal. eapply eventval_match_val_to_eventval; eauto. + Qed. + +End EVENT. + + + +Section IR. + + Variant ir_cont_type : Type := | ir_cont: block -> ir_cont_type. + Definition ir_conts := list ir_cont_type. + + Definition crossing_comp {F V} (ge: Genv.t F V) (cp cp': compartment) := + Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall. + + Definition ir_state := option (block * mem * ir_conts)%type. + + Variant ir_step (ge: Asm.genv) : ir_state -> (ident * bundle_event) -> ir_state -> Prop := + | ir_step_cross_call_internal + cur m1 ik + tr id evargs sg + cp cp' vargs + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + b f_next + (FINDB: Genv.find_symbol ge id = Some b) + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some (AST.Internal f_next)) + (CP': cp' = comp_of f_next) + (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) + (NPTR: crossing_comp ge cp cp' -> Forall not_ptr vargs) + (SIG: sg = Asm.fn_sig f_next) + (TR: call_trace_cross ge cp cp' b vargs (sig_args sg) tr id evargs) + d m2 + (DELTA: mem_delta_apply_wf ge cp d (Some m1) = Some m2) + (PUB: public_first_order ge m2) + id_cur + (IDCUR: Genv.invert_symbol ge cur = Some id_cur) + : + ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_call tr id evargs sg d) (Some (b, m2, (ir_cont cur) :: ik)) + | ir_step_cross_return_internal + cur m1 next ik ik_tl + tr evretv + cp_cur cp_next vretv + (CURCP: cp_cur = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + sg fd_cur + (FINDFD: Genv.find_funct_ptr ge cur = Some (fd_cur)) + (* in Asm, stack has the sig *) + (SIG: sg = Asm.funsig fd_cur) + (NPTR: crossing_comp ge cp_next cp_cur -> not_ptr vretv) + (NEXTCP: cp_next = Genv.find_comp ge (Vptr next Ptrofs.zero)) + f_next + (INTERNAL: Genv.find_funct_ptr ge next = Some (AST.Internal f_next)) + (* internal return: memory changes in Clight-side, so need inj-relation *) + (TR: return_trace_cross ge cp_next cp_cur vretv (sig_res sg) tr evretv) + (CONT: ik = (ir_cont next) :: ik_tl) + d m2 + (DELTA: mem_delta_apply_wf ge cp_cur d (Some m1) = Some m2) + (PUB: public_first_order ge m2) + id_cur + (IDCUR: Genv.invert_symbol ge cur = Some id_cur) + : + ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_return tr evretv d) (Some (next, m2, ik_tl)) + | ir_step_intra_call_external + cur m1 m2 ik + tr id evargs sg + cp_cur + (CURCP: cp_cur = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + b_ext ef cp_ext + (FINDB: Genv.find_symbol ge id = Some b_ext) + (FINDF: Genv.find_funct ge (Vptr b_ext Ptrofs.zero) = Some (AST.External ef)) + (EXTCP: cp_ext = comp_of ef) + (INTRA: Genv.type_of_call ge cp_cur cp_ext = Genv.InternalCall) + (SIG: sg = ef_sig ef) + d m1' + (MEM: mem_delta_apply_wf ge cp_cur d (Some m1) = Some m1') + vargs vretv + (EC: external_call ef ge vargs m1' tr vretv m2) + (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ + (external_call_known_observables ef ge m1' vargs tr vretv m2 /\ d = [])) + (ARGS: evargs = vals_to_eventvals ge vargs) + id_cur + (IDCUR: Genv.invert_symbol ge cur = Some id_cur) + : + ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_call tr id evargs sg d) (Some (cur, m2, ik)) + | ir_step_builtin + cur m1 m2 ik + tr ef evargs + cp_cur + (CURCP: cp_cur = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + (ALLOWED: comp_of ef = cp_cur) + d m1' + (MEM: mem_delta_apply_wf ge cp_cur d (Some m1) = Some m1') + vargs vretv + (EC: external_call ef ge vargs m1' tr vretv m2) + (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ + (external_call_known_observables ef ge m1' vargs tr vretv m2 /\ d = [])) + (ARGS: evargs = vals_to_eventvals ge vargs) + id_cur + (IDCUR: Genv.invert_symbol ge cur = Some id_cur) + : + ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_builtin tr ef evargs d) (Some (cur, m2, ik)) + | ir_step_cross_call_external1 + (* early cut at call *) + cur m1 ik + tr id evargs sg + cp cp' vargs + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + b ef + (FINDB: Genv.find_symbol ge id = Some b) + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some (AST.External ef)) + (CP': cp' = comp_of ef) + (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) + (NPTR: crossing_comp ge cp cp' -> Forall not_ptr vargs) + (SIG: sg = ef_sig ef) + (TR: call_trace_cross ge cp cp' b vargs (sig_args sg) tr id evargs) + id_cur + (IDCUR: Genv.invert_symbol ge cur = Some id_cur) + : + ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_call tr id evargs sg []) None + | ir_step_cross_call_external2 + (* early cut at call-ext_call *) + cur m1 ik + tr1 id evargs sg + cp cp' vargs + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + b ef + (FINDB: Genv.find_symbol ge id = Some b) + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some (AST.External ef)) + (CP': cp' = comp_of ef) + (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) + (NPTR: crossing_comp ge cp cp' -> Forall not_ptr vargs) + (SIG: sg = ef_sig ef) + (TR1: call_trace_cross ge cp cp' b vargs (sig_args sg) tr1 id evargs) + (* external function part *) + d m1' + (MEM: mem_delta_apply_wf ge cp d (Some m1) = Some m1') + tr2 m2 vretv + (TR2: external_call ef ge vargs m1' tr2 vretv m2) + (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ + (external_call_known_observables ef ge m1' vargs tr2 vretv m2 /\ d = [])) + (ARGS: evargs = vals_to_eventvals ge vargs) + id_cur + (IDCUR: Genv.invert_symbol ge cur = Some id_cur) + : + ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_call (tr1 ++ tr2) id evargs sg d) None + | ir_step_cross_call_external3 + (* early cut at call-ext_call *) + cur m1 ik + tr1 id evargs sg + cp cp' vargs + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + b ef + (FINDB: Genv.find_symbol ge id = Some b) + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some (AST.External ef)) + (CP': cp' = comp_of ef) + (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) + (NPTR: crossing_comp ge cp cp' -> Forall not_ptr vargs) + (SIG: sg = ef_sig ef) + (TR1: call_trace_cross ge cp cp' b vargs (sig_args sg) tr1 id evargs) + (* external function part *) + d m1' + (MEM: mem_delta_apply_wf ge cp d (Some m1) = Some m1') + tr2 m2 vretv + (TR2: external_call ef ge vargs m1' tr2 vretv m2) + (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ + (external_call_known_observables ef ge m1' vargs tr2 vretv m2 /\ d = [])) + (ARGS: evargs = vals_to_eventvals ge vargs) + (* return part *) + tr3 evretv + (NPTR: crossing_comp ge cp cp' -> not_ptr vretv) + f_cur + (INTERNAL: Genv.find_funct_ptr ge cur = Some (AST.Internal f_cur)) + (TR3: return_trace_cross ge cp cp' vretv (sig_res sg) tr3 evretv) + id_cur + (IDCUR: Genv.invert_symbol ge cur = Some id_cur) + : + ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_call (tr1 ++ tr2 ++ tr3) id evargs sg d) (Some (cur, m2, ik)). + +End IR. + + +Section AUX. + + Definition wf_ge {F V} (ge: Genv.t F V) := exists (p: AST.program F V), (list_norepet (prog_defs_names p)) /\ (ge = Genv.globalenv p). + + Lemma wf_ge_block_to_id + F V (ge: Genv.t F V) + (WF: wf_ge ge) + b gd + (DEF: Genv.find_def ge b = Some gd) + : + exists id, Genv.invert_symbol ge b = Some id. + Proof. destruct WF as (p & A & B). eapply genv_def_to_ident; eauto. Qed. + + Lemma val_is_ptr_or_not + (v: val) + : + (forall b o, v <> Vptr b o) \/ (exists b o, v = Vptr b o). + Proof. destruct v; eauto. all: left; intros; intros F; inv F. Qed. + +End AUX. + + +Section MEASURE. + + Inductive star_measure {genv state : Type} (step : genv -> state -> trace -> state -> Prop) (ge : genv) : nat -> state -> trace -> state -> Prop := + star_measure_refl : forall s : state, star_measure step ge O s E0 s + | star_step : forall n (s1 : state) (t1 : trace) (s2 : state) (t2 : trace) (s3 : state) (t : trace), + step ge s1 t1 s2 -> star_measure step ge n s2 t2 s3 -> t = t1 ** t2 -> star_measure step ge (S n) s1 t s3. + + Lemma measure_star + genv state + (step : genv -> state -> trace -> state -> Prop) + (ge : genv) + s0 tr s1 + (STAR: star step ge s0 tr s1) + : + exists n, star_measure step ge n s0 tr s1. + Proof. + induction STAR. + { exists O. constructor 1. } + destruct IHSTAR as (n & NEXT). exists (S n). econstructor 2. eapply H. eapply NEXT. auto. + Qed. + +End MEASURE. + + +Section CONDS. + + Definition public_not_freeable ge m := forall b, (meminj_public ge b <> None) -> (forall ofs, ~ Mem.perm m b ofs Max Freeable). + + Definition public_rev_perm ge m1 m2 := + forall b, match meminj_public ge b with + | Some (b', del) => forall ofs k p, Mem.perm m2 b' (ofs + del) k p -> Mem.perm m1 b ofs k p + | None => True + end. + +End CONDS. + + +Section FROMASM. + + Import ListNotations. + + Ltac Simplif_all := + ((rewrite Asmgenproof0.nextinstr_inv in * by eauto with asmgen) + || (rewrite Asmgenproof0.nextinstr_inv1 in * by eauto with asmgen) + || (rewrite Pregmap.gss in *) + || (rewrite Asmgenproof0.nextinstr_pc in *) + || (rewrite Pregmap.gso in * by eauto with asmgen)); auto with asmgen. + + Ltac Simpl_all := repeat Simplif_all. + + Ltac simpl_before_exists := + repeat (Simpl_all; + match goal with + (* Goto *) + | _: goto_label _ _ ?rs _ = Next _ _ |- _ => + unfold goto_label in *; destruct label_pos; try congruence + | _: eval_branch _ _ ?rs _ _ = Next _ _ |- _ => + unfold eval_branch in *; simpl in * + | _: exec_load _ _ _ _ _ _ _ _ _ = Next _ _ |- _ => + unfold exec_load in *; simpl in * + | _: exec_store _ _ _ _ _ _ _ _ = Next _ _ |- _ => + unfold exec_store in *; simpl in * + | _: context [Val.cmp_bool] |- _ => + unfold Val.cmp_bool in *; simpl in * + | _: context [Val.cmpl_bool] |- _ => + unfold Val.cmpl_bool in *; simpl in * + | _: context [eval_offset _ ?ofs] |- _ => + destruct ofs; simpl in * + + | |- context [Ptrofs.repr 0] => replace (Ptrofs.repr 0) with Ptrofs.zero by reflexivity; auto + | H: context [Ptrofs.repr 0] |- _ => replace (Ptrofs.repr 0) with Ptrofs.zero in H by reflexivity; auto + | |- context [Ptrofs.add _ Ptrofs.zero] => rewrite Ptrofs.add_zero; auto + | H: context [Ptrofs.add _ Ptrofs.zero] |- _ => rewrite Ptrofs.add_zero in H; simpl in *; try congruence + | |- context [Ptrofs.sub _ Ptrofs.zero] => rewrite Ptrofs.sub_zero_l; auto + | H: context [Ptrofs.sub _ Ptrofs.zero] |- _ => rewrite Ptrofs.sub_zero_l in H; simpl in *; try congruence + + (* hypothesis manipulation *) + | _: context [match ?rs1 ?i with | _ => _ end] |- _ => + destruct (rs1 i) eqn:?; try congruence; simpl in *; eauto + + | _: context [Val.offset_ptr (?rs1 ?i) _] |- _ => + destruct (rs1 i) eqn:?; try congruence; simpl in *; eauto + + | H: Next _ _ = Next _ _ |- _ => inv H + | H: Some _ = Some _ |- _ => inv H + | H: Some _ = None |- _ => inv H + | H: None = Some _ |- _ => inv H + | H: Stuck = Next _ _ |- _ => inv H + | H: Next _ _ = Stuck |- _ => inv H + | H: negb _ = true |- _ => apply negb_true_iff in H + | H: negb _ = false |- _ => apply negb_false_iff in H + | H: Int.eq ?x ?x = false |- _ => rewrite Int.eq_true in H + | H: Int64.eq ?x ?x = false |- _ => rewrite Int64.eq_true in H + | H: false = true |- _ => congruence + | H: true = false |- _ => congruence + | H: ?x = false, H': ?x = true |- _ => congruence + | H: match ?x with | _ => _ end = Next _ _ |- _ => + let eq := fresh "eq" in + destruct x eqn:eq; simpl in *; try congruence + | _: context [?rs1 ### ?rs] |- context [?rs3 ### ?rs] => + let i := fresh "i" in destruct rs as [| i]; simpl in * + | _: context [?rs1 ## ?rs] |- context [?rs3 ## ?rs] => + let i := fresh "i" in destruct rs as [| i]; simpl in * + | H: ?x = _ |- context [if ?x then _ else _] => + rewrite H; simpl + | H: ?x = _ |- context [match ?x with | _ => _ end] => + rewrite H; simpl + | |- context [(if ?x then _ else _) = Next _ _] => + let eq := fresh "eq" in destruct x eqn:eq; simpl in * + | |- context [(match ?x with | _ => _ end) = Next _ _] => + let eq := fresh "eq" in destruct x eqn:eq; simpl in * + + end); + simpl. + + Lemma public_not_freeable_free_inj_none + ge m + (NFREE: public_not_freeable ge m) + b lo hi cp m' + (FREE: Mem.free m b lo hi cp = Some m') + (BOUND: (lo < hi)%Z) + : + meminj_public ge b = None. + Proof. + destruct (meminj_public ge b) eqn:INJPUB; auto. exfalso. + eapply Mem.free_range_perm in FREE. unfold Mem.range_perm in FREE. + eapply NFREE. erewrite INJPUB. congruence. eapply Mem.perm_cur_max; apply FREE. + instantiate (1:=lo). lia. + Qed. + + Lemma public_not_freeable_store + ge m1 + (NFREE: public_not_freeable ge m1) + chunk b ofs v cp m2 + (STORE: Mem.store chunk m1 b ofs v cp = Some m2) + : + public_not_freeable ge m2. + Proof. + unfold public_not_freeable in *; intros b' H' ofs' CC; specialize (NFREE _ H' ofs'). + apply NFREE; eapply Mem.perm_store_2; eauto. + Qed. + + Lemma public_not_freeable_bytes + ge m1 + (NFREE: public_not_freeable ge m1) + b ofs mvs cp m2 + (STORE: Mem.storebytes m1 b ofs mvs cp = Some m2) + : + public_not_freeable ge m2. + Proof. + unfold public_not_freeable in *; intros b' H' ofs' CC; specialize (NFREE _ H' ofs'). + apply NFREE; eapply Mem.perm_storebytes_2; eauto. + Qed. + + Lemma public_not_freeable_alloc + ge m1 + (NALLOC: meminj_not_alloc (meminj_public ge) m1) + (NFREE: public_not_freeable ge m1) + cp lo hi m2 bn + (STORE: Mem.alloc m1 cp lo hi = (m2, bn)) + : + public_not_freeable ge m2. + Proof. + unfold public_not_freeable in *; intros b' H' ofs' CC; specialize (NFREE _ H' ofs'). + apply NFREE. eapply Mem.perm_alloc_4; eauto. + intros EQ; subst b'. apply H'. apply NALLOC. erewrite Mem.alloc_result; eauto. lia. + Qed. + + Lemma public_not_freeable_free + ge m1 + (NFREE: public_not_freeable ge m1) + b lo hi cp m2 + (STORE: Mem.free m1 b lo hi cp = Some m2) + : + public_not_freeable ge m2. + Proof. + unfold public_not_freeable in *; intros b' H' ofs' CC; specialize (NFREE _ H' ofs'). + apply NFREE. eapply Mem.perm_free_3; eauto. + Qed. + + Lemma public_not_freeable_exec_instr + (ge: genv) f i rs m cp rs' m' + (NFREE: public_not_freeable ge m) + (NALLOC: meminj_not_alloc (meminj_public ge) m) + (EXEC: exec_instr ge f i rs m cp = Next rs' m') + : + public_not_freeable ge m'. + Proof. + destruct i; simpl in EXEC. + all: try (inv EXEC; eauto). + all: simpl_before_exists; eauto. + all: try + (match goal with + | H: context [Mem.alloc] |- _ => idtac + | H: context [Mem.free] |- _ => idtac + | H: Mem.store ?ch ?m ?b ?ofs ?v ?cp = _ |- _ => + eapply public_not_freeable_store; eauto + end). + { eapply public_not_freeable_store. eapply public_not_freeable_alloc; eauto. eauto. } + { eapply public_not_freeable_free; eauto. } + Qed. + + Lemma public_rev_perm_store + ge m1 m' + (PRP: public_rev_perm ge m1 m') + chunk b ofs v cp m2 + (STORE: Mem.store chunk m1 b ofs v cp = Some m2) + : + public_rev_perm ge m2 m'. + Proof. + unfold public_rev_perm in *; intros. specialize (PRP b0). des_ifs. intros. + exploit PRP; eauto. intros. eapply Mem.perm_store_1; eauto. + Qed. + + Lemma public_rev_perm_bytes + ge m1 m' + (PRP: public_rev_perm ge m1 m') + b ofs mvs cp m2 + (STORE: Mem.storebytes m1 b ofs mvs cp = Some m2) + : + public_rev_perm ge m2 m'. + Proof. + unfold public_rev_perm in *; intros. specialize (PRP b0). des_ifs. intros. + exploit PRP; eauto. intros. eapply Mem.perm_storebytes_1; eauto. + Qed. + + Lemma public_rev_perm_alloc + ge m1 m' + (PRP: public_rev_perm ge m1 m') + cp lo hi m2 bn + (STORE: Mem.alloc m1 cp lo hi = (m2, bn)) + : + public_rev_perm ge m2 m'. + Proof. + unfold public_rev_perm in *; intros. specialize (PRP b). des_ifs. intros. + exploit PRP; eauto. intros. eapply Mem.perm_alloc_1; eauto. + Qed. + + Lemma public_rev_perm_free + ge m1 m' + (NFREE: public_not_freeable ge m1) + (PRP: public_rev_perm ge m1 m') + b lo hi cp m2 + (STORE: Mem.free m1 b lo hi cp = Some m2) + : + public_rev_perm ge m2 m'. + Proof. + unfold public_rev_perm in *; intros. specialize (PRP b0). des_ifs; clarify. intros. + exploit Mem.free_result; eauto. intros RES. unfold Mem.unchecked_free in RES. des_ifs. + { eapply PRP; eauto. } + exploit PRP; eauto. intros. eapply Mem.perm_free_1; eauto. + exploit Mem.free_range_perm; eauto. instantiate (1:=lo). lia. + intros PF. destruct (Pos.eqb_spec b b0); auto. subst b0. right. + unfold public_not_freeable in NFREE. exploit NFREE. rewrite Heq. congruence. 2: clarify. + eapply Mem.perm_max; eauto. + Qed. + + Lemma public_rev_perm_exec_instr + (ge: genv) f i rs m cp rs' m' + (NFREE: public_not_freeable ge m) + m0 + (PRP: public_rev_perm ge m m0) + (EXEC: exec_instr ge f i rs m cp = Next rs' m') + : + public_rev_perm ge m' m0. + Proof. + destruct i; simpl in EXEC. + all: try (inv EXEC; eauto). + all: simpl_before_exists; eauto. + all: try + (match goal with + | H: context [Mem.alloc] |- _ => idtac + | H: context [Mem.free] |- _ => idtac + | H: Mem.store ?ch ?m ?b ?ofs ?v ?cp = _ |- _ => + eapply public_rev_perm_store; eauto + end). + { eapply public_rev_perm_store. eapply public_rev_perm_alloc; eauto. eauto. } + { eapply public_rev_perm_free; eauto. } + Qed. + + Lemma meminj_not_alloc_delta + j m0 + (NALLOC: meminj_not_alloc j m0) + d m1 + (APPD: mem_delta_apply d (Some m0) = Some m1) + : + meminj_not_alloc j m1. + Proof. + revert m0 NALLOC m1 APPD. induction d; intros. + { simpl in *. inv APPD. auto. } + rewrite mem_delta_apply_cons in APPD. destruct a. + - destruct d0 as (((ch & ptr) & v) & cp). ss. exploit mem_delta_apply_some. eapply APPD. intros (mi & MEM). rewrite MEM in APPD. eapply IHd. 2: eapply APPD. + unfold meminj_not_alloc in *. intros. eapply NALLOC. destruct ptr; ss. erewrite Mem.nextblock_store in H; eauto. + - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. exploit mem_delta_apply_some. eapply APPD. intros (mi & MEM). rewrite MEM in APPD. eapply IHd. 2: eapply APPD. + unfold meminj_not_alloc in *. intros. eapply NALLOC. erewrite Mem.nextblock_store in H; eauto. + - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. exploit mem_delta_apply_some. eapply APPD. intros (mi & MEM). rewrite MEM in APPD. eapply IHd. 2: eapply APPD. + unfold meminj_not_alloc in *. intros. eapply NALLOC. erewrite Mem.nextblock_storebytes in H; eauto. + - destruct d0 as ((cp & lo) & hi). simpl in *. exploit mem_delta_apply_some. eapply APPD. intros (mi & MEM). rewrite MEM in APPD. eapply IHd. 2: eapply APPD. + unfold meminj_not_alloc in *. intros. eapply NALLOC. destruct (Mem.alloc m0 cp lo hi) eqn:MA. simpl in *. inv MEM. erewrite Mem.nextblock_alloc in H; eauto. lia. + - destruct d0 as (((b & lo) & hi) & cp). simpl in *. exploit mem_delta_apply_some. eapply APPD. intros (mi & MEM). rewrite MEM in APPD. eapply IHd. 2: eapply APPD. + unfold meminj_not_alloc in *. intros. eapply NALLOC. erewrite Mem.nextblock_free in H; eauto. + Qed. + + Lemma exec_instr_is_return + ge f i rs m cp rs' m' + (EXEC: exec_instr ge f i rs m cp = Next rs' m') + (ISRET: is_return i = true) + : + (exists v, rs' = (rs # PC <- v)) /\ (m' = m). + Proof. destruct i; simpl in *; clarify. split; eauto. Qed. + + Lemma exec_instr_is_call + ge f i rs m cp rs' m' + (EXEC: exec_instr ge f i rs m cp = Next rs' m') + sig + (ISRET: sig_call i = Some sig) + : + (rs' X1 = Val.offset_ptr rs#PC Ptrofs.one) /\ (m' = m). + Proof. destruct i; simpl in *; clarify. Qed. + + Lemma mem_delta_exec_instr + (ge: genv) f i rs m cp rs' m' + (NFREE: public_not_freeable ge m) + (EXEC: exec_instr ge f i rs m cp = Next rs' m') + m0 d + (DELTA0: mem_delta_inj_wf cp (meminj_public ge) d) + (DELTA1: mem_delta_apply d (Some m0) = Some m) + (NALLOC: meminj_not_alloc (meminj_public ge) m0) + : + exists d', (mem_delta_inj_wf cp (meminj_public ge) d') /\ (mem_delta_apply d' (Some m0) = Some m'). + Proof. + destruct i; simpl in EXEC. + all: try (inv EXEC; eauto). + all: simpl_before_exists; eauto. + all: try + (match goal with + | H: context [Mem.alloc] |- _ => idtac + | H: context [Mem.free] |- _ => idtac + | H: Mem.store ?ch ?m ?b (Ptrofs.unsigned ?ofs) ?v ?cp = _ |- _ => + exists (d ++ [mem_delta_kind_storev (ch, Vptr b ofs, v, cp)]); split + end; + [apply Forall_app; split; [auto | constructor; ss; auto] + | rewrite mem_delta_apply_app; (match goal with | H: mem_delta_apply _ _ = Some _ |- _ => rewrite H end; simpl; auto) ]). + { match goal with + | _: Mem.alloc _ ?cp1 ?lo ?hi = _, _: Mem.store ?ch _ ?b ?ofs ?v ?cp2 = _ |- _ => + exists (d ++ ([mem_delta_kind_alloc (cp1, lo, hi)] ++ [mem_delta_kind_store (ch, b, ofs, v, cp2)])) + end. + split. + - apply Forall_app; split; auto. apply Forall_app; split; constructor; simpl; auto. + hexploit meminj_not_alloc_delta. eauto. eapply DELTA1. intros NALLOC2. apply NALLOC2. + exploit Mem.alloc_result; eauto. lia. + - rewrite mem_delta_apply_app. rewrite DELTA1. rewrite mem_delta_apply_app. simpl. rewrite Heqp. simpl. auto. + } + { destruct (Z.leb_spec sz 0); cycle 1. + { match goal with + | _: Mem.free _ ?b ?lo ?hi ?cp = _ |- _ => + exists (d ++ [mem_delta_kind_free (b, lo, hi, cp)]) + end. + split. + - apply Forall_app; split; auto. constructor; auto. simpl. destruct (meminj_public ge b) eqn:INJPUB; auto. exfalso. + eapply Mem.free_range_perm in Heqo0. unfold Mem.range_perm in Heqo0. eapply NFREE. erewrite INJPUB. congruence. eapply Mem.perm_cur_max; apply Heqo0. instantiate (1:=0%Z). lia. + - rewrite mem_delta_apply_app. rewrite DELTA1. simpl. auto. + } + { apply Mem.free_result in Heqo0. unfold Mem.unchecked_free in Heqo0. unfold zle in Heqo0. des_ifs. eexists; eauto. } + } + Qed. + +End FROMASM. + + +Section INVS. + + Import ListNotations. + + Definition wf_stackframe (ge: Asm.genv) (fr: stackframe) := + match fr with + | Stackframe b _ _ _ _ => match Genv.find_funct_ptr ge b with + | Some (Internal f) => True + | _ => False + end + end. + Definition wf_stack (ge: Asm.genv) (sk: stack) := Forall (wf_stackframe ge) sk. + + Definition wf_regset (ge: Asm.genv) (rs: regset) := + match rs PC with + | Vptr b _ => match Genv.find_funct_ptr ge b with + | Some (Internal f) => True + | _ => False + end + | _ => False + end. + + Definition wf_asm (ge: Asm.genv) (ast: Asm.state) := + match ast with + | State sk rs m => (wf_stack ge sk) /\ (wf_regset ge rs) + | _ => False + end. + + + Definition wf_ir_cur (ge: Asm.genv) (cur: block) := + match Genv.find_funct_ptr ge cur with + | Some (Internal f) => True + | _ => False + end. + + Definition wf_ir_cont (ge: Asm.genv) (ik: ir_cont_type) := + match ik with + | ir_cont b => match Genv.find_funct_ptr ge b with + | Some (Internal f) => True + | _ => False + end + end. + Definition wf_ir_conts (ge: Asm.genv) (ik: ir_conts) := Forall (wf_ir_cont ge) ik. + + + Definition match_cur_stack_sig (cur: block) (ge: Asm.genv) (sk: stack) := + match Genv.find_funct_ptr ge cur with + | Some fd => Asm.funsig fd = sig_of_call sk + | _ => False + end. + + Definition match_cur_regset (cur: block) (ge: Asm.genv) (rs: regset) := + Genv.find_comp ge (Vptr cur Ptrofs.zero) = Genv.find_comp_ignore_offset ge (rs PC). + + Inductive match_stack (ge: Asm.genv): ir_conts -> stack -> Prop := + | match_stack_nil + : + match_stack ge [] [] + | match_stack_cons + next ik_tl + b cp sg v ofs sk_tl + (COMP: Genv.find_comp ge (Vptr next Ptrofs.zero) = Genv.find_comp ge (Vptr b Ptrofs.zero)) + (SIG: match_cur_stack_sig next ge sk_tl) + (TL: match_stack ge ik_tl sk_tl) + : + match_stack ge (ir_cont next :: ik_tl) (Stackframe b cp sg v ofs :: sk_tl). + + Definition match_mem (ge: Senv.t) cp (k: meminj) (d: mem_delta) (m_a0 m_i m_a1: mem): Prop := + let j := meminj_public ge in + (Mem.inject k m_a0 m_i) /\ (inject_incr j k) /\ + (meminj_not_alloc j m_a0) /\ (public_not_freeable ge m_a1) /\ + (mem_delta_inj_wf cp j d) /\ (mem_delta_apply d (Some m_a0) = Some m_a1) /\ + (public_rev_perm ge m_a1 m_i). + + Definition match_state (ge: Asm.genv) (k: meminj) (m_a0: mem) (d: mem_delta) (ast: Asm.state) (ist: ir_state): Prop := + match ast, ist with + | State sk rs m_a, Some (cur, m_i, ik) => + (wf_ir_cur ge cur) /\ (wf_ir_conts ge ik) /\ + (match_cur_stack_sig cur ge sk) /\ (match_cur_regset cur ge rs) /\ + (match_stack ge ik sk) /\ (match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + | _, _ => False + end. + +End INVS. + + +Section PROOF. + + Import ListNotations. + + Ltac end_case := do 2 eexists; split; [|constructor 1]; auto. + + Lemma asm_step_current_pc + cpm ge st rs m t s' + (STEP: step_fix cpm ge (State st rs m) t s') + : + exists b ofs, rs PC = Vptr b ofs. + Proof. destruct (rs PC) eqn:NEXTPC. 1,2,3,4,5: inv STEP; rewrite NEXTPC in H2; inv H2. eauto. Qed. + + Lemma asm_step_some_fundef + cpm ge st rs m t s' + (STEP: step_fix cpm ge (State st rs m) t s') + b ofs + (NEXTPC: rs PC = Vptr b ofs) + : + exists fd, Genv.find_funct_ptr ge b = Some fd. + Proof. destruct (Genv.find_funct_ptr ge b) eqn:CASE; eauto. exfalso. inv STEP; rewrite NEXTPC in H2; inv H2; rewrite CASE in H3; inv H3. Qed. + + Lemma asm_to_ir_compose + ge ist0 t t1 t2 + (ISTARS: exists btr1 ist1, + (unbundle_trace btr1 = t1 /\ istar ir_step ge ist0 btr1 ist1) + /\ exists btr2 ist2, + (unbundle_trace btr2 = t2 /\ istar ir_step ge ist1 btr2 ist2)) + (TR: t = t1 ** t2) + : + exists (btr : bundle_trace) (ist' : ir_state), + unbundle_trace btr = t /\ istar ir_step ge ist0 btr ist'. + Proof. + subst. destruct ISTARS as (btr1 & ist1 & (UTR1 & ISTAR1) & btr2 & ist2 & (UTR2 & ISTAR2)). + exists (btr1 ++ btr2). exists ist2. split; auto. + { rewrite unbundle_trace_app. rewrite UTR1, UTR2. auto. } + { eapply istar_trans; eauto. } + Qed. + + + Lemma visible_fo_meminj_fo + (ge: Senv.t) m tys args + (VFO: visible_fo ge m tys args) + : + meminj_first_order (meminj_public ge) m. + Proof. + destruct VFO as [PFO _]. ii. unfold public_first_order in PFO. unfold meminj_public in H. des_ifs. + exploit PFO; eauto. apply Senv.invert_find_symbol. auto. + Qed. + + Lemma external_call_unknowns_fo + ef (ge: Senv.t) m args + (ECC: external_call_unknowns ef ge m args) + : + meminj_first_order (meminj_public ge) m. + Proof. + unfold external_call_unknowns in ECC. des_ifs; eapply visible_fo_meminj_fo; eauto. + Qed. + + Lemma symbols_inject_meminj_public + F V (ge: Genv.t F V) + : + symbols_inject (meminj_public ge) ge ge. + Proof. + unfold symbols_inject. splits; intros; unfold meminj_public in *; auto. + - des_ifs. + - erewrite Senv.find_invert_symbol; eauto. rewrite H. eauto. + - des_ifs. + Qed. + + Lemma visible_fo_val_inject_list + (ge: Senv.t) m tys args + (VFO: visible_fo ge m tys args) + : + Val.inject_list (meminj_public ge) args args. + Proof. + destruct VFO as [PFO VP]. induction VP; ss. econs; eauto. clear dependent l. clear dependent l'. inv H; auto. + destruct H0 as [id [INV PUB]]. + econs. unfold meminj_public. rewrite INV. rewrite PUB. eauto. rewrite Ptrofs.add_zero. auto. + Qed. + + Lemma external_call_unknowns_val_inject_list + ef (ge: Senv.t) m args + (ECC: external_call_unknowns ef ge m args) + : + Val.inject_list (meminj_public ge) args args. + Proof. + unfold external_call_unknowns in ECC. des_ifs; eapply visible_fo_val_inject_list; eauto. + Qed. + + Lemma public_rev_perm_delta_apply_inj + d ge m m_i m_i' cp + (PRP: public_rev_perm ge m m_i) + (APPD: mem_delta_apply_wf ge cp d (Some m_i) = Some m_i') + : + public_rev_perm ge m m_i'. + Proof. + revert_until d. induction d; intros. + { unfold mem_delta_apply_wf in APPD. ss. clarify. } + rewrite mem_delta_apply_wf_cons in APPD. des_ifs; clarify; eauto. + exploit mem_delta_apply_wf_some; eauto. intros (m1 & STORE). rewrite STORE in APPD. + eapply IHd; clear IHd. 2: eauto. + unfold public_rev_perm in *. intros. specialize (PRP b). des_ifs. intros. + eapply PRP. unfold wf_mem_delta_kind_b in Heq. des_ifs. ss. unfold mem_delta_apply_storev in STORE. des_ifs. + destruct v0; ss. eapply Mem.perm_store_2; eauto. + Qed. + + Lemma mem_perm_any_to_nonempty + m b ofs k p + (PERM: Mem.perm m b ofs k p) + : + Mem.perm m b ofs k Nonempty. + Proof. + unfold Mem.perm in *. remember ((Mem.mem_access m) !! b ofs k) as k'. clear - PERM. destruct k'; ss. destruct p; ss; try constructor. + Qed. + + Lemma loc_first_order_memval_inject_preserves + (ge: Senv.t) m m' b ofs + (LFO: loc_first_order m b ofs) + (MVINJ: memval_inject (meminj_public ge) (ZMap.get ofs (Mem.mem_contents m) !! b) (ZMap.get ofs (Mem.mem_contents m') !! b)) + : + loc_first_order m' b ofs. + Proof. + unfold loc_first_order in *. remember (ZMap.get ofs (Mem.mem_contents m) !! b) as mv1. remember (ZMap.get ofs (Mem.mem_contents m') !! b) as mv2. + clear - LFO MVINJ. inv MVINJ; ss. + Qed. + + Lemma visible_fo_mem_inj + (ge: Senv.t) m tys args + (VFO: visible_fo ge m tys args) + m' + (MEMINJ: Mem.inject (meminj_public ge) m m') + (PRP: public_rev_perm ge m m') + : + visible_fo ge m' tys args. + Proof. + destruct VFO as [PFO VP]. split; auto. clear VP. clear - PFO MEMINJ PRP. + unfold public_first_order in *. intros. specialize (PRP b). unfold meminj_public in PRP. + exploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV, PUBLIC in PRP. + specialize (PRP ofs). rewrite Z.add_0_r in PRP. exploit PFO; eauto. intros LFO. + inv MEMINJ. inv mi_inj. exploit mi_memval. + { unfold meminj_public. rewrite INV, PUBLIC. eauto. } + { eauto. } + intros MVINJ. clear - LFO MVINJ. rewrite Z.add_0_r in MVINJ. eapply loc_first_order_memval_inject_preserves; eauto. + Qed. + + Lemma external_call_unknowns_mem_inj + (ge: Senv.t) m ef args + (ECC: external_call_unknowns ef ge m args) + m' + (MEMINJ: Mem.inject (meminj_public ge) m m') + (PRP: public_rev_perm ge m m') + : + external_call_unknowns ef ge m' args. + Proof. + unfold external_call_unknowns in *. des_ifs; eapply visible_fo_mem_inj; eauto. + Qed. + + Lemma match_mem_external_call_establish1 + (ge: genv) cp k d m_a0 m_i m + (MEM: match_mem ge cp k d m_a0 m_i m) + ef args t res m' + (EXTCALL: external_call ef ge args m t res m') + (ECC: external_call_unknowns ef ge m args) + : + exists m1 m2 res', + (mem_delta_apply_wf ge cp d (Some m_i) = Some m1) /\ + (external_call ef ge args m1 t res' m2) /\ + (external_call_unknowns ef ge m1 args) /\ + (exists k2, match_mem ge cp k2 [] m' m2 m' /\ Val.inject k2 res res') + . + Proof. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + (* reestablish meminj *) + exploit mem_delta_apply_establish_inject; eauto. + (* { apply meminj_public_strict. } *) + { eapply external_call_unknowns_fo. eauto. } + intros (m_i' & APPD' & MEMINJ'). + hexploit ec_mem_inject. eapply external_call_spec. 2: eapply EXTCALL. all: eauto. + (* hexploit external_call_mem_inject. 2: eapply EXTCALL. all: eauto. *) + { instantiate (1:=ge). apply symbols_inject_meminj_public. } + { instantiate (1:=args). eapply external_call_unknowns_val_inject_list; eauto. } + intros (f' & vres' & m_i'' & EXTCALL' & VALINJ' & MEMINJ'' & _ & _ & INCRINJ' & _). + assert (MM': match_mem ge cp f' [] m' m_i'' m'). + { unfold match_mem. simpl. + assert (PNF: public_not_freeable ge m'). + { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. + clear - EXTCALL MEM3 NALLOC. unfold public_not_freeable in *. intros. + specialize (MEM3 _ H). intros CC. apply (MEM3 ofs); clear MEM3. + eapply external_call_max_perm; eauto. unfold Mem.valid_block. + unfold meminj_not_alloc in NALLOC. unfold Plt. + destruct (Pos.ltb_spec b (Mem.nextblock m)); auto. + specialize (NALLOC _ H0). congruence. + } + pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. + assert (MNA: meminj_not_alloc (meminj_public ge) m'). + { clear - EXTCALL NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. + pose proof (@external_call_valid_block _ _ _ _ _ _ _ b EXTCALL). + destruct (Pos.leb_spec (Mem.nextblock m) b); auto. + unfold Mem.valid_block in H0. apply H0 in H1. exfalso. unfold Plt in H1. lia. + } + splits; auto. + { constructor. } + { hexploit public_rev_perm_delta_apply_inj; eauto. intros PRP2. clear - MEM3 PRP2 EXTCALL EXTCALL' PNF NALLOC MEMINJ' MEMINJ'' INCRINJ'. + unfold public_rev_perm in *. intros. specialize (PRP2 b). des_ifs. intros. + hexploit Mem.perm_inject_inv. eapply MEMINJ''. eapply INCRINJ'. eapply Heq. eauto. intros [PERM | PERM]; auto. + pose proof Heq as PUB. unfold meminj_public in PUB. des_ifs. + assert (VB: Mem.valid_block m b0). + { unfold meminj_not_alloc in NALLOC. unfold Mem.valid_block. destruct (Pos.ltb_spec b0 (Mem.nextblock m)); auto. exfalso. + exploit NALLOC; eauto. intros. clarify. + } + exfalso. apply PERM. eapply external_call_public_not_freeable; eauto. + { eapply PRP2. eapply external_call_max_perm. eauto. + { eapply Mem.valid_block_inject_2; eauto. } + eapply Mem.perm_max. eapply mem_perm_any_to_nonempty. eauto. + } + { unfold public_not_freeable in MEM3. eapply MEM3. rewrite Heq. congruence. } + } + } + exists m_i', m_i'', vres'. splits; eauto. + { assert (PRP: public_rev_perm ge m m_i'). + { eapply public_rev_perm_delta_apply_inj; eauto. } + clear - ECC MEMINJ' PRP. eapply external_call_unknowns_mem_inj; eauto. + } + Qed. + + + Lemma asm_to_ir_returnstate_nccc_internal + cpm (ge: genv) n n0 + (LT: (n0 < n)%nat) + (IH: forall y : nat, + (y < n)%nat -> + forall (m_a0 : mem) (ast ast' : state) (tr : trace), + wf_ge ge -> + wf_asm ge ast -> + star_measure (step_fix cpm) ge y ast tr ast' -> + forall (ist : ir_state) (k : meminj) (d : mem_delta), + match_state ge k m_a0 d ast ist -> + exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') + (WFGE: wf_ge ge) + cur ik + (WFIR0 : wf_ir_cur ge cur) + (WFIR1 : wf_ir_conts ge ik) + st (rs: regset) + (WFASM1: wf_stack ge st) + (MTST0 : match_cur_stack_sig cur ge st) + (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) + (MTST2 : match_stack ge ik st) + k d m_a0 m_i m_a + (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + t' ast' + (STEP: step_fix cpm ge (ReturnState st rs m_a) t' ast') + t'' ast'' + (STAR: star_measure (step_fix cpm) ge n0 ast' t'' ast'') + (NCCC: Genv.type_of_call ge (Genv.find_comp_ignore_offset ge (rs PC)) (callee_comp cpm st) <> Genv.CrossCompartmentCall) + b1 ofs1 + (NEXTPC: rs PC = Vptr b1 ofs1) + f + (NEXTF : Genv.find_funct_ptr ge b1 = Some (Internal f)) + : + exists (btr : bundle_trace) (ist' : ir_state), + unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. + Proof. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + (** step --- ReturnState *) + inv STEP. inv EV; simpl in *. + 2:{ rewrite H in NCCC. congruence with NCCC. } + (** return is nccc *) + clear H. pose proof STAR as STAR0. inv STAR. + (* end case *) + { end_case. } + (* has next step - internal -> done*) + rename H into STEP, H0 into STAR. + (** next is internal *) + exploit IH; clear IH. 4: eapply STAR0. lia. all: auto. + { simpl. split. + - unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. + - unfold wf_regset in *. rewrite NEXTPC, NEXTF. auto. + } + { instantiate (4:=k). instantiate (3:=m_a0). instantiate (2:=d). instantiate (1:=Some (cur, m_i, ik)). + assert (st' = st). + { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } + subst st'. simpl. split; auto. split; auto. split; auto. split. + { unfold match_cur_regset in *. rewrite CURCOMP. unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. auto. } + split; auto. + { unfold match_mem. splits; auto. } + } + intros (btr & ist' & UTR & ISTAR'). + exists btr, ist'. split; auto. + Qed. + + Lemma match_mem_external_call_establish2 + ge cp k d m_a0 m_i m + (MEM: match_mem ge cp k d m_a0 m_i m) + ef args t res m' + (EXTCALL: external_call ef ge args m t res m') + (ECKO: external_call_known_observables ef ge m args t res m') + : + (external_call ef ge args m_i t res m_i) /\ + (external_call_known_observables ef ge m_i args t res m_i) /\ + (match_mem ge cp k d m_a0 m_i m') + . + Proof. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + unfold external_call_known_observables in ECKO. + des_ifs; simpl in *. + { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. esplits; eauto. + 1,2: econs; econs; eauto. unfold match_mem. splits; auto. + } + { destruct ECKO as [_ [OBS WCH]]. inv EXTCALL. inv H; simpl in *; clarify. esplits; eauto. + 1,2: econs; econs; eauto. unfold match_mem. splits; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } + { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } + { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } + { destruct ECKO as [_ OBS]. inv EXTCALL. esplits; eauto. + 1,2: econs; eauto. unfold match_mem. splits; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL. esplits; eauto. + 1,2: econs; eauto. unfold match_mem. splits; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } + Qed. + + Lemma match_mem_external_call_establish + (ge: genv) cp k d m_a0 m_i m + (MEM: match_mem ge cp k d m_a0 m_i m) + ef args t res m' + (EXTCALL: external_call ef ge args m t res m') + (ECC: external_call_unknowns ef ge m args \/ external_call_known_observables ef ge m args t res m') + : + exists d' m1 m2 res', + (mem_delta_apply_wf ge cp d' (Some m_i) = Some m1) /\ + (external_call ef ge args m1 t res' m2) /\ + ((external_call_unknowns ef ge m1 args) \/ (external_call_known_observables ef ge m1 args t res' m2 /\ d' = [])) /\ + (exists k2 d2 m_a02, match_mem ge cp k2 d2 m_a02 m2 m' /\ (Val.inject k2 res res' \/ (res = res'))) + . + Proof. + destruct ECC as [ECC | ECC]. + - exploit match_mem_external_call_establish1; eauto. intros. des. esplits; eauto. + - exploit match_mem_external_call_establish2; eauto. intros. des. esplits; eauto. ss. + Qed. + + Lemma asm_to_ir_step_external + cpm (ge: genv) + (WFGE: wf_ge ge) + cur ik + (WFIR0 : wf_ir_cur ge cur) + (WFIR1 : wf_ir_conts ge ik) + st (rs: regset) + (WFASM1: wf_stack ge st) + (MTST0 : match_cur_stack_sig cur ge st) + (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) + (MTST2 : match_stack ge ik st) + k d m_a0 m_i m_a + (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + t ast' + (STEP: step_fix cpm ge (State st rs m_a) t ast') + b1 ofs1 + (NEXTPC: rs PC = Vptr b1 ofs1) + ef + (NEXTF : Genv.find_funct_ptr ge b1 = Some (External ef)) + n t' ast'' + (STAR: star_measure (step_fix cpm) ge n ast' t' ast'') + : + exists (btr : bundle_trace) k' d' m_a0' m_i' m_a', + (unbundle_trace btr = t) /\ + (istar ir_step ge (Some (cur, m_i, ik)) btr (Some (cur, m_i', ik))) /\ + (match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k' d' m_a0' m_i' m_a') /\ + (exists res, star_measure (step_fix cpm) ge n + (ReturnState st (set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs)) # PC <- (rs X1) m_a') t' ast''). + Proof. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + assert (exists id_cur, Genv.invert_symbol ge cur = Some id_cur). + { clear - WFGE WFIR0. unfold wf_ir_cur in WFIR0. unfold Genv.find_funct_ptr in WFIR0. + des_ifs. eapply wf_ge_block_to_id; eauto. + } + des. rename H into IDCUR. + (* take a step *) + inv STEP. + (* invalid *) + 1,2,3,4: rewrite NEXTPC in H2; inv H2; rewrite NEXTF in H3; inv H3. + rewrite NEXTPC in H2; inv H2; rewrite NEXTF in H3; inv H3. + exploit Genv.find_funct_ptr_iff. intros (TEMP & _). specialize (TEMP NEXTF). + exploit wf_ge_block_to_id; eauto. intros (ef_id & INVSYMB). + exploit Genv.invert_find_symbol. eapply INVSYMB. intros FINDSYMB. clear TEMP. + exploit extcall_cases. eapply ECC. eauto. clear ECC. intros [ECU | [ECKO | ECKS]]. + + - (* extcall is unknown *) + exploit match_mem_external_call_establish1; eauto. unfold match_mem; splits; eauto. + intros. des. + exists ([(id_cur, Bundle_call t ef_id (vals_to_eventvals ge args) (ef_sig ef0) (d))]). + do 5 eexists. splits; simpl. 3: eapply x3. apply app_nil_r. + 2:{ exists res. auto. } + econstructor 2. 2: econstructor 1. 2: eauto. + eapply ir_step_intra_call_external; eauto. + { unfold Genv.type_of_call in *. rewrite CURCOMP, <- REC_CURCOMP. rewrite NEXTPC. simpl. + unfold Genv.find_comp. setoid_rewrite NEXTF. rewrite Pos.eqb_refl. auto. + } + + - (* extcall is known and observable *) + rename H4 into EXTCALL, H7 into EXTARGS. unfold external_call_known_observables in ECKO. + des_ifs; simpl in *. + { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. + exists ([(id_cur, Bundle_call [Event_vload chunk id ofs ev] ef_id [EVptr_global id ofs] {| sig_args := [Tptr]; sig_res := rettype_of_chunk chunk; sig_cc := cc_default |} ([]))]). + exists k, d, m_a0, m_i, m'. simpl. splits; auto. 2: split; auto. 2: eauto. + econstructor 2. 2: econstructor 1. 2: auto. + eapply ir_step_intra_call_external. all: eauto. + { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } + { ss. } + { simpl. econstructor. econstructor 1; eauto. } + { simpl. right. split; auto. econs; eauto. econs. econs; eauto. } + { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. } + splits; auto. + } + { destruct ECKO as [_ [OBS WCH]]. inv EXTCALL. inv H; simpl in *; clarify. + exists ([(id_cur, Bundle_call [Event_vstore chunk id ofs ev] ef_id [EVptr_global id ofs; ev] {| sig_args := [Tptr; type_of_chunk chunk]; sig_res := Tvoid; sig_cc := cc_default |} ([]))]). + exists k, d, m_a0, m_i, m'. simpl. splits; auto. 2: split; auto. 2: eauto. + econstructor 2. 2: econstructor 1. 2: auto. + eapply ir_step_intra_call_external. all: eauto. + { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } + { ss. } + { instantiate (2:=[Vptr b0 ofs; Val.load_result chunk v]). + simpl. econstructor. econstructor 1; eauto. rewrite val_load_result_idem. auto. + } + { simpl. right. split; auto. + splits; ss; auto. econs; eauto. econs; eauto. rewrite val_load_result_idem. auto. des. + unfold load_whole_chunk in *. rewrite val_load_result_idem. auto. + } + { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. + f_equal. erewrite eventval_match_val_to_eventval; eauto. + } + splits; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } + { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } + { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } + { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. + exists ([(id_cur, Bundle_call [Event_annot text args0] ef_id (vals_to_eventvals ge args) {| sig_args := targs; sig_res := Tvoid; sig_cc := cc_default |} ([]))]). + exists k, d, m_a0, m_i, m'. simpl. splits; auto. 2: split; auto. 2: eauto. + econstructor 2. 2: econstructor 1. 2: auto. + eapply ir_step_intra_call_external. all: eauto. + { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } + { ss. } + { simpl. econstructor. auto. } + { simpl. right. split; auto. econs; eauto. econs. auto. } + splits; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. + exists ([(id_cur, Bundle_call [Event_annot text [arg]] ef_id [val_to_eventval ge res] {| sig_args := [targ]; sig_res := targ; sig_cc := cc_default |} ([]))]). + exists k, d, m_a0, m_i, m'. simpl. splits; auto. 2: split; auto. 2: eauto. + econstructor 2. 2: econstructor 1. 2: auto. + eapply ir_step_intra_call_external. all: eauto. + { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } + { ss. } + { simpl. econstructor. eauto. } + { simpl. right. split; auto. econs; eauto. econs. auto. } + { simpl. auto. } + splits; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } + + - (* extcall is known and silent *) + rename H4 into EXTCALL, H7 into EXTARGS. unfold external_call_known_silents in ECKS. + des_ifs; ss; clarify. + { unfold builtin_or_external_sem in EXTCALL. rewrite Heq in EXTCALL. inv EXTCALL. + exists [], k, d, m_a0, m_i, m'. simpl. splits; auto. 2: unfold match_mem; splits; auto. 2: eauto. econstructor 1. + } + { unfold builtin_or_external_sem in EXTCALL. rewrite Heq in EXTCALL. inv EXTCALL. + exists [], k, d, m_a0, m_i, m'. simpl. splits; auto. 2: unfold match_mem; splits; auto. 2: eauto. econstructor 1. + } + { destruct ECKS as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. + exists [], k, d, m_a0, m_i, m'. simpl. splits; auto. 2: unfold match_mem; splits; auto. 2: eauto. econstructor 1. + } + { destruct ECKS as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. + exists [], k, (d ++ [mem_delta_kind_storev (chunk, Vptr b0 ofs, v, cp)]), m_a0, m_i, m'. simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. + { eapply public_not_freeable_store; eauto. } + { setoid_rewrite Forall_app. split; auto. econs; auto. ss. + rewrite CURCOMP. rewrite <- REC_CURCOMP. rewrite NEXTPC. ss. unfold Genv.find_comp. setoid_rewrite NEXTF. ss. + } + { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } + { eapply public_rev_perm_store; eauto. } + } + { destruct ECKS as [_ OBS]. inv EXTCALL. + exists [], k, (d ++ [mem_delta_kind_alloc (cp, (- size_chunk Mptr), (Ptrofs.unsigned sz)); mem_delta_kind_store (Mptr, b0, (- size_chunk Mptr), (Vptrofs sz), cp)]), m_a0, m_i, m'. + simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. + { eapply public_not_freeable_store. 2: eauto. eapply public_not_freeable_alloc. + 3: eauto. all: auto. + eapply meminj_not_alloc_delta; eauto. + } + { setoid_rewrite Forall_app. split; auto. econs; auto. + { simpl. auto. } + econs; auto. simpl. hexploit Mem.alloc_result; eauto. hexploit meminj_not_alloc_delta; eauto. + intros. apply H1. lia. + } + { rewrite mem_delta_apply_app. rewrite MEM5. simpl. rewrite H. simpl. auto. } + { eapply public_rev_perm_store. 2: eauto. eapply public_rev_perm_alloc. + 2: eauto. all: auto. + } + } + { destruct ECKS as [_ OBS]. inv EXTCALL. + - exists [], k, (d ++ [mem_delta_kind_free (b0, (Ptrofs.unsigned lo - size_chunk Mptr)%Z, (Ptrofs.unsigned lo + Ptrofs.unsigned sz)%Z, cp)]), m_a0, m_i, m'. + simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. + { eapply public_not_freeable_free; eauto. } + { setoid_rewrite Forall_app. split; auto. econs; auto. simpl. + eapply public_not_freeable_free_inj_none; eauto. + { unfold size_chunk. unfold Mptr. des_ifs; lia. } + } + { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } + { eapply public_rev_perm_free; eauto. } + - exists [], k, d, m_a0, m_i, m'. + simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. + } + { destruct ECKS as [_ [OBS NPUB]]. inv EXTCALL. + exists [], k, (d ++ [mem_delta_kind_bytes (bdst, (Ptrofs.unsigned odst), bytes, cp)]), m_a0, m_i, m'. + simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. + { eapply public_not_freeable_bytes; eauto. } + { setoid_rewrite Forall_app. split; auto. econs; auto. simpl. + clear - NPUB. simpl in NPUB. unfold meminj_public. des_ifs. exfalso. apply NPUB. + exists i. auto. + } + { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } + { eapply public_rev_perm_bytes; eauto. } + } + + { destruct ECKS as [_ OBS]. inv EXTCALL. clarify. } + { destruct ECKS as [_ OBS]. inv EXTCALL. clarify. } + { destruct ECKS as [_ OBS]. inv EXTCALL. + exists [], k, d, m_a0, m_i, m'. simpl. splits; auto. 2: unfold match_mem; splits; auto. 2: eauto. econstructor 1. + } + + Qed. + + Lemma asm_to_ir_builtin + (ge: genv) + m_a0 + (WFGE: wf_ge ge) + rs m st + (WFASM: wf_asm ge (State st rs m)) + cur m_i ik k d + (MTST: match_state ge k m_a0 d (State st rs m) (Some (cur, m_i, ik))) + t1 ef vres m' b ofs f vargs + (CURPC: rs PC = Vptr b ofs) + (CURF: Genv.find_funct_ptr ge b = Some (Internal f)) + (EXTCALL: external_call ef ge vargs m t1 vres m') + (ALLOWED: comp_of ef = comp_of f) + (ECC: external_call_conds ef ge m vargs) + : + exists (btr : bundle_trace) k' d' m_a0' m_i', + (unbundle_trace btr = t1) /\ + (istar ir_step ge (Some (cur, m_i, ik)) btr (Some (cur, m_i', ik))) /\ + (match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k' d' m_a0' m_i' m'). + Proof. + ss. destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). + destruct MTST3 as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + destruct WFASM as [WFASM0 WFASM1]. + assert (exists id_cur, Genv.invert_symbol ge cur = Some id_cur). + { clear - WFGE WFIR0. unfold wf_ir_cur in WFIR0. unfold Genv.find_funct_ptr in WFIR0. + des_ifs. eapply wf_ge_block_to_id; eauto. + } + des. rename H into IDCUR. + exploit extcall_cases. eapply ECC. eauto. clear ECC. intros [ECU | [ECKO | ECKS]]. + + - (* extcall is unknown *) + exploit match_mem_external_call_establish1; eauto. unfold match_mem; splits; eauto. + intros. des. + exists ([(id_cur, Bundle_builtin t1 ef (vals_to_eventvals ge vargs) d)]). + do 4 eexists. splits; simpl. 3: eapply x3. apply app_nil_r. + econstructor 2. 2: econstructor 1. 2: eauto. + eapply ir_step_builtin; eauto. + { rewrite ALLOWED. rewrite MTST1, CURPC. ss. unfold Genv.find_comp. + setoid_rewrite CURF. ss. + } + + - (* extcall is known and observable *) + unfold external_call_known_observables in ECKO. + des_ifs; simpl in *. + { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. + exists ([(id_cur, Bundle_builtin [Event_vload chunk id ofs0 ev] (EF_vload cp chunk) [EVptr_global id ofs0] [])]). + exists k, d, m_a0, m_i. simpl. splits; auto. 2: split; auto. + econstructor 2. 2: econstructor 1. 2: auto. + eapply ir_step_builtin. all: eauto. + { rewrite ALLOWED. rewrite MTST1, CURPC. ss. unfold Genv.find_comp. + setoid_rewrite CURF. ss. + } + { ss. } + { simpl. econstructor. econstructor 1; eauto. } + { simpl. right. split; auto. econs; eauto. econs. econs; eauto. } + { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. } + splits; auto. + } + { destruct ECKO as [_ [OBS WCH]]. inv EXTCALL. inv H; simpl in *; clarify. + exists ([(id_cur, Bundle_builtin [Event_vstore chunk id ofs0 ev] (EF_vstore cp chunk) [EVptr_global id ofs0; ev] [])]). + exists k, d, m_a0, m_i. simpl. splits; auto. 2: split; auto. + econstructor 2. 2: econstructor 1. 2: auto. + eapply ir_step_builtin. all: eauto. + { rewrite ALLOWED. rewrite MTST1, CURPC. ss. unfold Genv.find_comp. + setoid_rewrite CURF. ss. + } + { ss. } + { instantiate (2:=[Vptr b0 ofs0; Val.load_result chunk v]). + simpl. econstructor. econstructor 1; eauto. rewrite val_load_result_idem. auto. + } + { simpl. right. split; auto. splits; eauto. econs. econs; eauto. rewrite val_load_result_idem. auto. + unfold load_whole_chunk in *. rewrite val_load_result_idem. auto. + } + { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. + f_equal. erewrite eventval_match_val_to_eventval; eauto. + } + splits; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } + { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } + { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } + { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. + exists ([(id_cur, Bundle_builtin [Event_annot text args] (EF_annot cp kind text targs) (vals_to_eventvals ge vargs) [])]). + exists k, d, m_a0, m_i. simpl. splits; auto. 2: split; auto. + econstructor 2. 2: econstructor 1. 2: auto. + eapply ir_step_builtin. all: eauto. + { rewrite ALLOWED. rewrite MTST1, CURPC. ss. unfold Genv.find_comp. + setoid_rewrite CURF. ss. + } + { ss. } + { simpl. econstructor. auto. } + { simpl. right. split; auto. econs; eauto. econs. auto. } + splits; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. + exists ([(id_cur, Bundle_builtin [Event_annot text [arg]] (EF_annot_val cp kind text targ) [val_to_eventval ge vres] [])]). + exists k, d, m_a0, m_i. simpl. splits; auto. 2: split; auto. + econstructor 2. 2: econstructor 1. 2: auto. + eapply ir_step_builtin. all: eauto. + { rewrite ALLOWED. rewrite MTST1, CURPC. ss. unfold Genv.find_comp. + setoid_rewrite CURF. ss. + } + { ss. } + { simpl. econstructor. eauto. } + { simpl. right. split; auto. econs; eauto. econs. auto. } + { simpl. auto. } + splits; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } + + - (* extcall is known and silent *) + unfold external_call_known_silents in ECKS. des_ifs; ss; clarify. + { unfold builtin_or_external_sem in EXTCALL. rewrite Heq in EXTCALL. inv EXTCALL. + exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: rr; splits; auto. econstructor 1. + } + { unfold builtin_or_external_sem in EXTCALL. rewrite Heq in EXTCALL. inv EXTCALL. + exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: rr; splits; auto. econstructor 1. + } + { destruct ECKS as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. + exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: rr; splits; auto. econstructor 1. + } + { destruct ECKS as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. + exists [], k, (d ++ [mem_delta_kind_storev (chunk, Vptr b0 ofs0, v, cp)]), m_a0, m_i. simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. + { eapply public_not_freeable_store; eauto. } + { setoid_rewrite Forall_app. split; auto. econs; auto. ss. + rewrite MTST1. rewrite CURPC. ss. unfold Genv.find_comp. setoid_rewrite CURF. auto. + } + { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } + { eapply public_rev_perm_store; eauto. } + } + { destruct ECKS as [_ OBS]. inv EXTCALL. + exists [], k, (d ++ [mem_delta_kind_alloc (cp, (- size_chunk Mptr), (Ptrofs.unsigned sz)); mem_delta_kind_store (Mptr, b0, (- size_chunk Mptr), (Vptrofs sz), cp)]), m_a0, m_i. + simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. + { eapply public_not_freeable_store. 2: eauto. eapply public_not_freeable_alloc. + 3: eauto. all: auto. + eapply meminj_not_alloc_delta; eauto. + } + { setoid_rewrite Forall_app. split; auto. econs; auto. + { simpl. auto. } + econs; auto. simpl. hexploit Mem.alloc_result; eauto. hexploit meminj_not_alloc_delta; eauto. + intros. apply H1. lia. + } + { rewrite mem_delta_apply_app. rewrite MEM5. simpl. rewrite H. simpl. auto. } + { eapply public_rev_perm_store. 2: eauto. eapply public_rev_perm_alloc. + 2: eauto. all: auto. + } + } + { destruct ECKS as [_ OBS]. inv EXTCALL. + - exists [], k, (d ++ [mem_delta_kind_free (b0, (Ptrofs.unsigned lo - size_chunk Mptr)%Z, (Ptrofs.unsigned lo + Ptrofs.unsigned sz)%Z, cp)]), m_a0, m_i. + simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. + { eapply public_not_freeable_free; eauto. } + { setoid_rewrite Forall_app. split; auto. econs; auto. simpl. + eapply public_not_freeable_free_inj_none; eauto. + { unfold size_chunk. unfold Mptr. des_ifs; lia. } + } + { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } + { eapply public_rev_perm_free; eauto. } + - exists [], k, d, m_a0, m_i. + simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. + } + { destruct ECKS as [_ [OBS NPUB]]. inv EXTCALL. + exists [], k, (d ++ [mem_delta_kind_bytes (bdst, (Ptrofs.unsigned odst), bytes, cp)]), m_a0, m_i. + simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. + { eapply public_not_freeable_bytes; eauto. } + { setoid_rewrite Forall_app. split; auto. econs; auto. simpl. + clear - NPUB. simpl in NPUB. unfold meminj_public. des_ifs. exfalso. apply NPUB. + exists i. auto. + } + { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } + { eapply public_rev_perm_bytes; eauto. } + } + + { destruct ECKS as [_ OBS]. inv EXTCALL. clarify. } + { destruct ECKS as [_ OBS]. inv EXTCALL. clarify. } + { destruct ECKS as [_ OBS]. inv EXTCALL. + exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: rr; splits; auto. econstructor 1. + } + + Qed. + + + Lemma asm_to_ir_returnstate_undef_nccc_external + cpm (ge: genv) n n0 + (LT: (n0 < n)%nat) + (IH: forall y : nat, + (y < n)%nat -> + forall (m_a0 : mem) (ast ast' : state) (tr : trace), + wf_ge ge -> + wf_asm ge ast -> + star_measure (step_fix cpm) ge y ast tr ast' -> + forall (ist : ir_state) (k : meminj) (d : mem_delta), + match_state ge k m_a0 d ast ist -> + exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') + (WFGE: wf_ge ge) + cur ik + (WFIR0 : wf_ir_cur ge cur) + (WFIR1 : wf_ir_conts ge ik) + st (rs: regset) + (WFASM1: wf_stack ge st) + (MTST0 : match_cur_stack_sig cur ge st) + (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) + (MTST2 : match_stack ge ik st) + k d m_a0 m_i m_a + (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + (RSX: rs X1 = Vundef) + t' ast' + (STEP: step_fix cpm ge (ReturnState st rs m_a) t' ast') + t'' ast'' + (STAR: star_measure (step_fix cpm) ge n0 ast' t'' ast'') + (NCCC: Genv.type_of_call ge (Genv.find_comp_ignore_offset ge (rs PC)) (callee_comp cpm st) <> Genv.CrossCompartmentCall) + b1 ofs1 + (NEXTPC: rs PC = Vptr b1 ofs1) + ef + (NEXTF : Genv.find_funct_ptr ge b1 = Some (External ef)) + : + exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. + Proof. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + (** step --- ReturnState *) + inv STEP. inv EV; simpl in *. + 2:{ rewrite H in NCCC. congruence with NCCC. } + (** return is nccc *) + clear H. pose proof STAR as STAR0. inv STAR. + (* end case *) + { end_case. } + (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) + (* take a step *) + rename H into STEP, H0 into STAR. + + assert (st' = st). + { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } + subst st'. + exploit asm_to_ir_step_external. + 12: eapply STAR. 11: eapply NEXTF. 10: eapply NEXTPC. 9: eapply STEP. + all: eauto. + { rr; splits; eauto. } + clear STEP STAR. + intros (btr1 & k' & d' & m_a0' & m_i' & m_a' & UTR1 & ISTAR1 & MM' & (res & STAR)). + eapply asm_to_ir_compose. 2: eauto. do 2 eexists. split; eauto. clear btr1 UTR1 ISTAR1. + + assert (STUCK: (set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs)) + # PC <- (rs X1) PC = Vundef). + { rewrite Pregmap.gss. auto. } + inv STAR. + (* end case *) + { exists []. eexists. split; auto. econstructor 1. } + (* now at Returnstate *) + inv H; simpl in *. rewrite Pregmap.gss in *. inv H0. + (* end case *) + { inv EV. + (* return is NCCC - silent *) + { exists []. simpl. eexists. split; auto. econstructor 1. } + (* return is CCC - return event *) + { unfold Genv.type_of_call in H. des_ifs. unfold update_stack_return in STUPD0. + clear H. rewrite Pregmap.gss in *. + rewrite Pos.eqb_sym in Heq. rewrite Heq in STUPD0. des_ifs. + pose proof Heq as NEQ. eapply Pos.eqb_neq in NEQ. specialize (PC_RA0 NEQ). + (* stuck --- return PC is Vundef *) + rewrite STUCK in PC_RA0. clear - PC_RA0. exfalso. simpl in PC_RA0. des_ifs. + } + } + (* stuck case *) + inv H; simpl in *; rewrite Pregmap.gss in *; rewrite STUCK in H5; inv H5. + Qed. + + Lemma asm_to_ir_returnstate_ccc + cpm (ge: genv) n n0 + (LT: (n0 < n)%nat) + (IH: forall y : nat, + (y < n)%nat -> + forall (m_a0 : mem) (ast ast' : state) (tr : trace), + wf_ge ge -> + wf_asm ge ast -> + star_measure (step_fix cpm) ge y ast tr ast' -> + forall (ist : ir_state) (k : meminj) (d : mem_delta), + match_state ge k m_a0 d ast ist -> + exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') + (WFGE: wf_ge ge) + cur ik + (WFIR0 : wf_ir_cur ge cur) + (WFIR1 : wf_ir_conts ge ik) + st (rs: regset) + (WFASM1: wf_stack ge st) + (MTST0 : match_cur_stack_sig cur ge st) + (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) + (MTST2 : match_stack ge ik st) + k d m_a0 m_i m_a + (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + t' ast' + (STEP: step_fix cpm ge (ReturnState st rs m_a) t' ast') + t'' ast'' + (STAR: star_measure (step_fix cpm) ge n0 ast' t'' ast'') + (CCC: Genv.type_of_call ge (Genv.find_comp_ignore_offset ge (rs PC)) (callee_comp cpm st) = Genv.CrossCompartmentCall) + : + exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. + Proof. + assert (exists id_cur, Genv.invert_symbol ge cur = Some id_cur). + { clear - WFGE WFIR0. unfold wf_ir_cur in WFIR0. unfold Genv.find_funct_ptr in WFIR0. + des_ifs. eapply wf_ge_block_to_id; eauto. + } + des. rename H into IDCUR. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + (** step --- ReturnState *) + inv STEP. inv EV; simpl in *. + { rewrite CCC in H. congruence with H. } + clear H. specialize (CHECKPUB CCC). + (** return is ccc --- next is poped from the stack, which is internal, so done *) + unfold Genv.type_of_call in CCC. des_ifs. clear CCC. unfold update_stack_return in STUPD. + rewrite Pos.eqb_sym in Heq. rewrite Heq in STUPD. des_ifs. + pose proof Heq as NEQ. eapply Pos.eqb_neq in NEQ. specialize (PC_RA NEQ). + destruct s as [b3 cp3 sig3 rv3 ptr3]. simpl in *. + inv WFASM1. simpl in *. des_ifs. clear H2. inv MTST2. + hexploit mem_delta_apply_establish_inject. eapply MEM0. 1,2,3,4: eauto. + { clear - CHECKPUB. ii. unfold public_first_order in CHECKPUB. unfold meminj_public in H. des_ifs. + eapply CHECKPUB; eauto. apply Senv.invert_find_symbol; auto. + } + intros (m_i' & APPD & MEMINJ). + exploit (IH _ _ _ _ _ _ _ _ STAR). lia. all: auto. + { simpl. split; auto. unfold wf_regset. rewrite PC_RA. rewrite Heq0. auto. } + { instantiate (4:=(meminj_public ge)). instantiate (3:=m_a). instantiate (2:=[]). + instantiate (1:=Some (next, m_i', ik_tl)). simpl. splits; auto. + { inv WFIR1. simpl in *. auto. } + { inv WFIR1. auto. } + { unfold match_cur_regset. rewrite COMP. rewrite PC_RA. auto. } + { rr; splits; auto. eapply meminj_not_alloc_delta; eauto. ss. eapply public_rev_perm_delta_apply_inj; eauto. + } + } + intros (btr & ist' & UTR & ISTAR'). + exists ((id_cur, Bundle_return [Event_return (Genv.find_comp_ignore_offset ge (rs PC)) (Genv.find_comp ge (Vptr cur Ptrofs.zero)) res] res d) :: btr), ist'. + simpl. rewrite UTR. split; auto. + econstructor 2. 2: eapply ISTAR'. 2: auto. + inv WFIR1. simpl in *. des_ifs. clear H2. unfold wf_ir_cur in WFIR0. des_ifs. clear WFIR0. + eapply ir_step_cross_return_internal. 6: eapply Heq1. all: eauto. + { rewrite COMP. rewrite PC_RA. simpl. auto. } + { constructor; auto. + { unfold Genv.type_of_call. rewrite Pos.eqb_sym, Heq. auto. } + { replace (funsig (Internal f2)) with sig3; auto. unfold match_cur_stack_sig in MTST0. des_ifs. } + } + { hexploit public_rev_perm_delta_apply_inj. eauto. eapply APPD. intros REVP. clear - MEMINJ CHECKPUB REVP. + unfold public_first_order in *. i. + exploit Senv.find_invert_symbol; eauto. intros INV. + assert (PERM: Mem.perm m_a b ofs Cur Readable). + { specialize (REVP b). unfold meminj_public in REVP. rewrite INV, PUBLIC in REVP. apply REVP. rewrite Z.add_0_r. auto. } + eapply loc_first_order_memval_inject_preserves. eapply CHECKPUB; eauto. + instantiate (1:=ge). inv MEMINJ. inv mi_inj. replace ofs with (ofs + 0)%Z at 2 by lia. eapply mi_memval; auto. + unfold meminj_public. rewrite INV, PUBLIC. auto. + } + Qed. + + Lemma asm_to_ir_returnstate_undef + cpm (ge: genv) n n0 + (LT: (n0 < n)%nat) + (IH: forall y : nat, + (y < n)%nat -> + forall (m_a0 : mem) (ast ast' : state) (tr : trace), + wf_ge ge -> + wf_asm ge ast -> + star_measure (step_fix cpm) ge y ast tr ast' -> + forall (ist : ir_state) (k : meminj) (d : mem_delta), + match_state ge k m_a0 d ast ist -> + exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') + (WFGE: wf_ge ge) + cur ik + (WFIR0 : wf_ir_cur ge cur) + (WFIR1 : wf_ir_conts ge ik) + st (rs: regset) + (WFASM1: wf_stack ge st) + (MTST0 : match_cur_stack_sig cur ge st) + (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) + (MTST2 : match_stack ge ik st) + k d m_a0 m_i m_a + (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + (RSX: rs X1 = Vundef) + t' ast' + (STEP: step_fix cpm ge (ReturnState st rs m_a) t' ast') + t'' ast'' + (STAR: star_measure (step_fix cpm) ge n0 ast' t'' ast'') + : + exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. + Proof. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + (** step --- ReturnState *) + pose proof STEP as STEP0. inv STEP. inv EV; simpl in *. + (** return is nccc *) + { rename H into NCCC. pose proof STAR as STAR0. inv STAR. + (* end case *) + { end_case. } + (* has next step - if internal, done; if external, ub by RSX *) + rename H into STEP, H0 into STAR. exploit asm_step_current_pc. eapply STEP. intros (b1 & ofs1 & NEXTPC). + exploit asm_step_some_fundef. eapply STEP. eapply NEXTPC. intros (fd & NEXTF). + destruct fd. + (** next is internal *) + { exploit asm_to_ir_returnstate_nccc_internal. 2: eapply IH. + 11: eapply STAR0. 10: eapply STEP0. all: eauto. rr; splits; eauto. + } + (** next is external --- undef *) + { exploit asm_to_ir_returnstate_undef_nccc_external. 2: eapply IH. + 12: eapply STAR0. 11: eapply STEP0. all: eauto. rr; splits; eauto. + } + } + (** return is ccc --- next is poped from the stack, which is internal, so done *) + { exploit asm_to_ir_returnstate_ccc. 2: eapply IH. + 11: eapply STAR. 10: eapply STEP0. all: eauto. rr; splits; eauto. + } + Qed. + + Lemma asm_to_ir_returnstate_nccc_external + cpm (ge: genv) n n0 + (LT: (n0 < n)%nat) + (IH: forall y : nat, + (y < n)%nat -> + forall (m_a0 : mem) (ast ast' : state) (tr : trace), + wf_ge ge -> + wf_asm ge ast -> + star_measure (step_fix cpm) ge y ast tr ast' -> + forall (ist : ir_state) (k : meminj) (d : mem_delta), + match_state ge k m_a0 d ast ist -> + exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') + (WFGE: wf_ge ge) + cur ik + (WFIR0 : wf_ir_cur ge cur) + (WFIR1 : wf_ir_conts ge ik) + st (rs: regset) + (WFASM1: wf_stack ge st) + (MTST0 : match_cur_stack_sig cur ge st) + (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) + (MTST2 : match_stack ge ik st) + k d m_a0 m_i m_a + (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + t' ast' + (STEP: step_fix cpm ge (ReturnState st rs m_a) t' ast') + t'' ast'' + (STAR: star_measure (step_fix cpm) ge n0 ast' t'' ast'') + (NCCC: Genv.type_of_call ge (Genv.find_comp_ignore_offset ge (rs PC)) (callee_comp cpm st) <> Genv.CrossCompartmentCall) + b1 ofs1 + (NEXTPC: rs PC = Vptr b1 ofs1) + ef + (NEXTF : Genv.find_funct_ptr ge b1 = Some (External ef)) + : + exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. + Proof. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + (** step --- ReturnState *) + inv STEP. inv EV; simpl in *. + 2:{ rewrite H in NCCC. congruence with NCCC. } + (** return is nccc *) + clear H. pose proof STAR as STAR0. inv STAR. + (* end case *) + { end_case. } + (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) + (* take a step *) + rename H into STEP, H0 into STAR. + + assert (st' = st). + { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } + subst st'. + exploit asm_to_ir_step_external. + 12: eapply STAR. 11: eapply NEXTF. 10: eapply NEXTPC. 9: eapply STEP. + all: eauto. + { rr; splits; eauto. } + clear STEP STAR. + intros (btr1 & k' & d' & m_a0' & m_i' & m_a' & UTR1 & ISTAR1 & MM' & (res & STAR)). + eapply asm_to_ir_compose. 2: eauto. do 2 eexists. split; eauto. clear btr1 UTR1 ISTAR1. + + inv STAR. + (* end case *) + { exists []. eexists. split; auto. econstructor 1. } + (* now at Returnstate *) + eapply asm_to_ir_returnstate_undef. 2: eapply IH. 12: eapply H0. 11: eapply H. + all: eauto. lia. + { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } + Qed. + + Lemma asm_to_ir_returnstate + cpm (ge: genv) n n0 + (LT: (n0 < n)%nat) + (IH: forall y : nat, + (y < n)%nat -> + forall (m_a0 : mem) (ast ast' : state) (tr : trace), + wf_ge ge -> + wf_asm ge ast -> + star_measure (step_fix cpm) ge y ast tr ast' -> + forall (ist : ir_state) (k : meminj) (d : mem_delta), + match_state ge k m_a0 d ast ist -> + exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') + (WFGE: wf_ge ge) + cur ik + (WFIR0 : wf_ir_cur ge cur) + (WFIR1 : wf_ir_conts ge ik) + st (rs: regset) + (WFASM1: wf_stack ge st) + (MTST0 : match_cur_stack_sig cur ge st) + (CURCOMP : Genv.find_comp ge (Vptr cur Ptrofs.zero) = callee_comp cpm st) + (MTST2 : match_stack ge ik st) + k d m_a0 m_i m_a + (MEM: match_mem ge (Genv.find_comp ge (Vptr cur Ptrofs.zero)) k d m_a0 m_i m_a) + t' ast' + (STEP: step_fix cpm ge (ReturnState st rs m_a) t' ast') + t'' ast'' + (STAR: star_measure (step_fix cpm) ge n0 ast' t'' ast'') + : + exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t' ** t'' /\ istar ir_step ge (Some (cur, m_i, ik)) btr ist'. + Proof. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + (** step --- ReturnState *) + pose proof STEP as STEP0. inv STEP. inv EV; simpl in *. + (** return is nccc *) + { rename H into NCCC. pose proof STAR as STAR0. inv STAR. + (* end case *) + { end_case. } + (* has next step - if internal, done; if external, one external step and X1 = undef *) + rename H into STEP, H0 into STAR. exploit asm_step_current_pc. eapply STEP. intros (b1 & ofs1 & NEXTPC). + exploit asm_step_some_fundef. eapply STEP. eapply NEXTPC. intros (fd & NEXTF). + destruct fd. + (** next is internal *) + { exploit asm_to_ir_returnstate_nccc_internal. 2: eapply IH. + 11: eapply STAR0. 10: eapply STEP0. all: eauto. rr; splits; eauto. + } + (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) + { exploit asm_to_ir_returnstate_nccc_external. 2: eapply IH. + 11: eapply STAR0. 10: eapply STEP0. all: eauto. rr; splits; eauto. + } + } + (** return is ccc --- next is poped from the stack, which is internal, so done *) + { exploit asm_to_ir_returnstate_ccc. 2: eapply IH. + 11: eapply STAR. 10: eapply STEP0. all: eauto. rr; splits; eauto. + } + Qed. + + Lemma asm_to_ir_nccc_internal + cpm ge n n' + (LT: (n < n')%nat) + (IH: forall y : nat, + (y < n')%nat -> + forall (m_a0 : mem) (ast ast' : state) (tr : trace), + wf_ge ge -> + wf_asm ge ast -> + star_measure (step_fix cpm) ge y ast tr ast' -> + forall (ist : ir_state) (k : meminj) (d : mem_delta), + match_state ge k m_a0 d ast ist -> + exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = tr /\ istar ir_step ge ist btr ist') + m_a0 ast' + (WFGE: wf_ge ge) + rs m st + (WFASM: wf_asm ge (State st rs m)) + ist k d + (MTST: match_state ge k m_a0 d (State st rs m) ist) + t2 rs' m' + (STAR: star_measure (step_fix cpm) ge n (State st rs' m') t2 ast') + b ofs f i b' ofs' + (H0: rs PC = Vptr b ofs) + (H1: Genv.find_funct_ptr ge b = Some (Internal f)) + (H2: find_instr (Ptrofs.unsigned ofs) (fn_code f) = Some i) + (H3: exec_instr ge f i rs m (comp_of f) = Next rs' m') + (NEXTPC: rs' PC = Vptr b' ofs') + (ALLOWED: comp_of f = Genv.find_comp_ignore_offset ge (Vptr b' ofs')) + : + exists (btr : bundle_trace) (ist' : ir_state), unbundle_trace btr = t2 /\ istar ir_step ge ist btr ist'. + Proof. + destruct (Genv.find_funct_ptr ge b') eqn:NEXTF. + (* no next function *) + 2:{ move STAR after NEXTF. inv STAR. + (* end case *) + { end_case. } + (* take a step *) + { inv H. + (* invalid *) + all: exfalso; rewrite NEXTPC in H8; inv H8; rewrite NEXTF in H9; inv H9. + } + } + unfold match_state in MTST. destruct ist as [[[cur m_i] ik] |]. + 2:{ inv MTST. } + destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). destruct MTST3 as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + exploit mem_delta_exec_instr. eapply MEM3. eapply H3. + { replace (comp_of f) with (Genv.find_comp ge (Vptr cur Ptrofs.zero)). eapply MEM4. + rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp. setoid_rewrite H1. auto. + } + eapply MEM5. auto. intros (d' & MEM4' & MEM5'). + destruct f0. + + (** has next function --- internal *) + { assert (WFASM': wf_asm ge (State st rs' m')). + { clear IH. unfold wf_asm in *. destruct WFASM as [WFASM0 WFASM1]. split; [auto|]. + unfold wf_regset in *. rewrite H0, H1 in WFASM1. rewrite NEXTPC, NEXTF. auto. + } + assert (MTST': match_state ge k m_a0 d' (State st rs' m') (Some (cur, m_i, ik))). + { clear IH. split. auto. split. auto. split. auto. split. + { unfold match_cur_regset in *. rewrite NEXTPC. rewrite <- ALLOWED. rewrite MTST1. + unfold Genv.find_comp_ignore_offset. rewrite H0. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. + rewrite H1. auto. + } + split. auto. + { unfold match_mem. splits; auto. + eapply public_not_freeable_exec_instr. 3: eapply H3. all: auto. eapply meminj_not_alloc_delta; eauto. + { replace (Genv.find_comp ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. + rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp. setoid_rewrite H1. auto. + } + eapply public_rev_perm_exec_instr. 3: eapply H3. all: auto. + } + } + exploit IH. 4: eapply STAR. 3: apply WFASM'. 3: eapply MTST'. all: auto. + } + + (** has next function --- external *) + { move STAR after NEXTF. inv STAR. + (* end case *) + { end_case. } + (* take a step *) + destruct WFASM as [WFASM0 WFASM1]. + exploit asm_to_ir_step_external. 12: eapply H4. 11: eapply NEXTF. 10: eapply NEXTPC. 9: eapply H. all: eauto. + { inv H. + 1,2,3,4: rewrite NEXTPC in H8; inv H8; rewrite NEXTF in H9; inv H9. + rewrite <- REC_CURCOMP. rewrite H8. rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H8; inv H8. rewrite <- ALLOWED. + unfold Genv.find_comp. setoid_rewrite H1. auto. + } + { instantiate (4:=k). instantiate (3:=d'). unfold match_mem. splits; eauto. + eapply public_not_freeable_exec_instr; eauto. eapply meminj_not_alloc_delta; eauto. + { replace (Genv.find_comp ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. + rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp. setoid_rewrite H1. auto. + } + eapply public_rev_perm_exec_instr; eauto. + } + intros (btr' & k' & d'0 & m_a0' & m_i' & m_a' & UTR' & ISTAR' & MM' & (res' & STAR')). + eapply asm_to_ir_compose. 2: eauto. + exists btr'. eexists. split. + { split; auto. eapply ISTAR'. } + clear btr' UTR' ISTAR'. rename H into STEP0, H4 into STAR0. + inv STAR'. + { end_case. } + exploit asm_to_ir_returnstate_undef. 2: eapply IH. 12: eapply H4. 11: eapply H. 9: eapply MM'. all: eauto. + { lia. } + { inv STEP0. + 1,2,3,4: rewrite NEXTPC in H8; inv H8; rewrite NEXTF in H9; inv H9. + rewrite <- REC_CURCOMP. rewrite H8. rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H8; inv H8. rewrite <- ALLOWED. + unfold Genv.find_comp. setoid_rewrite H1. auto. + } + { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } + } + Qed. + + Lemma asm_to_ir_ccc_external1 + ge rs cur + (MTST1 : match_cur_regset cur ge rs) + rs' e b ofs f args + (H0 : rs PC = Vptr b ofs) + (H1 : Genv.find_funct_ptr ge b = Some (Internal f)) + ofs0 b0 + (ALLOWED : Genv.allowed_call ge (comp_of f) (Vptr b0 Ptrofs.zero)) + (NEXTPC : rs' PC = Vptr b0 ofs0) + (TYPEC : Genv.type_of_call ge (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) = Genv.CrossCompartmentCall) + (NO_CROSS_PTR : Forall not_ptr args) + (CALLSIG : Genv.find_funct_ptr ge b0 = Some (External e)) + vl i0 + (H3 : Genv.invert_symbol ge b0 = Some i0) + (H4 : eventval_list_match ge vl (sig_args (ef_sig e)) args) + : + exists cp cp' sg, + (cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) /\ + (Genv.find_symbol ge i0 = Some b0) /\ + (Genv.find_funct ge (Vptr b0 Ptrofs.zero) = Some (External e)) /\ + (cp' = comp_of e) /\ + (Genv.allowed_call ge cp (Vptr b0 Ptrofs.zero)) /\ + (crossing_comp ge cp cp' -> Forall not_ptr args) /\ + (sg = ef_sig e) /\ + (call_trace_cross ge cp cp' b0 args (sig_args sg) [Event_call (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) i0 vl] i0 vl). + Proof. + assert (EQC : Genv.find_comp ge (Vptr b Ptrofs.zero) = comp_of f). + { unfold Genv.find_comp. setoid_rewrite H1. auto. } + assert (EQC2 : Genv.find_comp ge (Vptr b0 Ptrofs.zero) = comp_of e). + { unfold Genv.find_comp. setoid_rewrite CALLSIG. auto. } + do 3 eexists. + ss. splits; auto. + - eapply Genv.invert_find_symbol; auto. + - replace (Genv.find_comp ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. rewrite MTST1, H0. ss. + - econs; auto. + + unfold Genv.type_of_call. + replace (comp_of e) with (Genv.find_comp ge (Vptr b0 Ptrofs.zero)); auto. + replace (Genv.find_comp ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. rewrite MTST1, H0. ss. + + replace (comp_of e) with (Genv.find_comp ge (Vptr b0 Ptrofs.zero)); auto. + replace (Genv.find_comp ge (Vptr cur Ptrofs.zero)) with (comp_of f); auto. rewrite MTST1, H0. ss. + Qed. + + Lemma arguments_same + rs m sig args1 args2 + (CARGS: call_arguments rs m sig args1) + (EARGS: extcall_arguments rs m sig args2) + : + args1 = args2. + Proof. + unfold call_arguments in CARGS. unfold extcall_arguments in EARGS. + unfold Conventions.loc_parameters in CARGS. remember (Conventions1.loc_arguments sig) as clas. clear dependent sig. + move args1 after rs. revert_until args1. induction args1; ss; intros. + { inv CARGS. symmetry in H0. apply map_eq_nil in H0. subst. inv EARGS. auto. } + inv CARGS. symmetry in H. apply map_eq_cons in H. des; clarify. + inv EARGS. f_equal. + 2:{ eapply IHargs1; eauto. } + clear - H2 H1. inv H1; ss. + - inv H2. inv H. + + ss. inv H1; auto. + + inv H1; auto. unfold Mem.loadv in *. des_ifs. apply Mem.load_Some_None in H2, H5. rewrite H2 in H5. inv H5. auto. + - inv H2. inv H. + + inv H0. + * inv H4. inv H6. auto. + * inv H4. inv H6. unfold Mem.loadv in *. des_ifs. apply Mem.load_Some_None in H1, H4. rewrite H1 in H4. inv H4. auto. + + inv H0. + * inv H4. inv H6. unfold Mem.loadv in *. des_ifs. apply Mem.load_Some_None in H2, H5. rewrite H2 in H5. inv H5. auto. + * inv H4. inv H6. unfold Mem.loadv in *. des_ifs. apply Mem.load_Some_None in H1, H2, H5, H7. rewrite H2 in H7. rewrite H1 in H5. clarify. + Qed. + + + (* If main is External, treat it as a different case - + the trace can start with Event_syscall, without a preceding Event_call *) + Theorem asm_to_ir + cpm (ge: genv) m_a0 + ast ast' tr + (WFGE: wf_ge ge) + (WFASM: wf_asm ge ast) + (STAR: star (Asm.step_fix cpm) ge ast tr ast') + ist k d + (MTST: match_state ge k m_a0 d ast ist) + : + exists btr ist', (unbundle_trace btr = tr) /\ (istar (ir_step) ge ist btr ist'). + Proof. + apply measure_star in STAR. destruct STAR as (n & STAR). + move n before ge. revert m_a0 ast ast' tr WFGE WFASM STAR ist k d MTST. + pattern n. apply (well_founded_induction Nat.lt_wf_0). intros n1 IH. intros. + inv STAR; subst. + (* end case *) + { end_case. } + rename H0 into STAR. inv H; simpl. + + - (** internal *) + eapply asm_to_ir_nccc_internal; eauto. + + - (** internal_call *) + assert (EQC: (Genv.find_comp_ignore_offset ge (Vptr b Ptrofs.zero)) = (comp_of f)). + { ss. unfold Genv.find_comp. setoid_rewrite H1. auto. } + destruct (Genv.type_of_call ge (comp_of f) (Genv.find_comp_ignore_offset ge (Vptr b' ofs'))) eqn:TYPEC. + (* case nccc: same as the previous *) + { assert (st' = st). + { unfold Genv.type_of_call in TYPEC. des_ifs. unfold update_stack_call in STUPD. rewrite EQC in STUPD. rewrite NEXTPC, Heq in STUPD. inv STUPD. auto. } + subst. + exploit asm_to_ir_nccc_internal. 2: eapply IH. 5: eapply STAR. all: eauto. rewrite <- EQC; auto. + { unfold Genv.type_of_call in TYPEC. des_ifs. rewrite Pos.eqb_eq in Heq. auto. } + intros RES. inv EV. simpl. apply RES. rewrite TYPEC in H. inv H. + } + + (* case ccc *) + { destruct ist as [[[cur m_i] ik] |]; ss. + destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). + destruct WFASM as [WFASM0 WFASM1]. + specialize (CALLSIG eq_refl). des. + exploit exec_instr_is_call; eauto. clear H2 H3 H4. intros (RSX & MEM). subst m'. + assert (exists id_cur, Genv.invert_symbol ge cur = Some id_cur). + { clear - WFGE WFIR0. unfold wf_ir_cur in WFIR0. unfold Genv.find_funct_ptr in WFIR0. + des_ifs. eapply wf_ge_block_to_id; eauto. + } + des. rename H into IDCUR. + destruct fd. + (* calling internal function *) + { inv EV. + { rewrite TYPEC in H. clarify. } + clear H. clarify. unfold update_stack_call in STUPD. des_ifs. + { unfold Genv.type_of_call in TYPEC. rewrite NEXTPC in Heq. rewrite <- EQC in TYPEC. ss. rewrite Heq in TYPEC. inv TYPEC. } + ss. eapply asm_to_ir_compose. + 2:{ instantiate (2:=[Event_call (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) i0 vl]). simpl. eauto. } + assert (EQC2: (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) = comp_of f0). + { unfold Genv.find_comp. setoid_rewrite CALLSIG. auto. } + specialize (CHECKPUB eq_refl). + pose proof MTST3 as MEM. destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). + hexploit mem_delta_apply_establish_inject. eapply MEM0. 1,2,3,4: eauto. + { clear - CHECKPUB. ii. unfold public_first_order in CHECKPUB. unfold meminj_public in H. des_ifs. + eapply CHECKPUB; eauto. apply Senv.invert_find_symbol; auto. + } + intros (m_i' & APPD & MEMINJ). + exists ([(id_cur, Bundle_call [Event_call (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) i0 vl] i0 vl (fn_sig f0) d)]). eexists. split. + { simpl. split; auto. econstructor 2. 2: econstructor 1. 2: eauto. eapply ir_step_cross_call_internal. + 7: eauto. 6: intros; eapply NO_CROSS_PTR; auto. 3: setoid_rewrite CALLSIG; auto. 3,4: eauto. + { rewrite MTST1. rewrite <- EQC, H0. simpl. auto. } + { apply Genv.invert_find_symbol; auto. } + { econs; auto. } + { replace (comp_of f) with (Genv.find_comp ge (Vptr cur Ptrofs.zero)). eapply APPD. rewrite MTST1. rewrite H0. ss. } + { hexploit public_rev_perm_delta_apply_inj. eauto. eapply APPD. intros REVP. clear - MEMINJ CHECKPUB REVP. + unfold public_first_order in *. i. + exploit Senv.find_invert_symbol; eauto. intros INV. + assert (PERM: Mem.perm m b ofs Cur Readable). + { specialize (REVP b). unfold meminj_public in REVP. rewrite INV, PUBLIC in REVP. apply REVP. rewrite Z.add_0_r. auto. } + eapply loc_first_order_memval_inject_preserves. eapply CHECKPUB; eauto. + instantiate (1:=ge). inv MEMINJ. inv mi_inj. replace ofs with (ofs + 0)%Z at 2 by lia. eapply mi_memval; auto. + unfold meminj_public. rewrite INV, PUBLIC. auto. + } + auto. + } + rewrite H0 in RSX. simpl in RSX. inv RSX. + eapply IH. 4: eapply STAR. all: auto. + { ss. split. + - econs; auto. ss. rewrite H1. auto. + - unfold wf_regset. rewrite NEXTPC. rewrite CALLSIG. auto. + } + unfold match_state. splits; eauto. + - unfold wf_ir_cur. rewrite CALLSIG. auto. + - econs; eauto. + - unfold match_cur_stack_sig. rewrite CALLSIG. ss. + - unfold match_cur_regset. rewrite NEXTPC. ss. + - econs; eauto. rewrite MTST1. rewrite H0. ss. + - instantiate (3:=(meminj_public ge)). instantiate (2:=[]). instantiate (1:=m). + rr; splits; auto. eapply meminj_not_alloc_delta; eauto. ss. eapply public_rev_perm_delta_apply_inj; eauto. + } + (* calling external function *) + { assert (EQC2: (Genv.find_comp ge (Vptr b' Ptrofs.zero)) = comp_of e). + { unfold Genv.find_comp. setoid_rewrite CALLSIG. auto. } + inv EV. + { rewrite TYPEC in H. clarify. } + clear H. clarify. unfold update_stack_call in STUPD. des_ifs. + { unfold Genv.type_of_call in TYPEC. rewrite NEXTPC in Heq. rewrite <- EQC in TYPEC. ss. rewrite Heq in TYPEC. inv TYPEC. } + pose proof STAR as STAR0. move STAR after H4. + exploit asm_to_ir_ccc_external1. eapply MTST1. eapply H0. eapply H1. eapply ALLOWED. eapply NEXTPC. all: auto. eapply CALLSIG. eapply H3. eapply H4. + intros (cp & cp' & sg & FACT1 & FACT2 & FACT3 & FACT4 & FACT5 & FACT6 & FACT7 & FACT8). subst. + inv STAR; ss. + (* subcase 1 *) + { exists ([(id_cur, Bundle_call [Event_call (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) i0 vl] i0 vl (ef_sig e) [])]). eexists. ss. split; auto. + econs 2. 2: econs 1. 2: eauto. eapply ir_step_cross_call_external1. + 8: eapply FACT8. 6: eapply FACT6. 5: eapply FACT5. 3: eapply FACT3. 2: eapply FACT2. all: eauto. + } + rename H into STEP, H2 into STAR, TYPEC into CCC, CALLSIG into NEXTF. inv STEP. + 1,2,3,4: rewrite NEXTPC in H6; inv H6; rewrite NEXTF in H7; inv H7. + rewrite NEXTPC in H6; inv H6. rewrite NEXTF in H7; inv H7. ss. clear REC_CURCOMP. rename H8 into EXTCALL, H11 into EXTARGS. + assert (NEQCP: comp_of f <> comp_of ef). + { rewrite <- EQC2. clear - CCC. intros CC. unfold Genv.type_of_call in CCC. rewrite CC in CCC. rewrite Pos.eqb_refl in CCC. inv CCC. } + exploit extcall_cases. eapply ECC. eapply EXTCALL. clear ECC. rewrite <- or_assoc. intros [ECC | ECC]. + 2:{ exfalso. clear - NEXTF NEQCP ALLOWED ECC. destruct ALLOWED as [A | A]. + { rewrite A in NEQCP. unfold Genv.find_comp in NEQCP. setoid_rewrite NEXTF in NEQCP. auto. } + unfold Genv.allowed_cross_call in A. destruct A as (i & cp' & INV & OK & _). unfold Genv.find_funct_ptr in NEXTF. specialize (OK _ NEXTF). + destruct ef; ss; clarify. des_ifs. des_ifs. + { destruct ECC as [ECC1 ECC2]. subst. inv ECC1. } + { destruct ECC as [ECC1 ECC2]. subst. inv ECC1. } + } + exploit arguments_same; eauto. intros EQ. subst args0. + exploit match_mem_external_call_establish; eauto. intros. + destruct x0 as (d' & m1 & m2 & res' & EFACT1 & EFACT2 & EFACT3 & (k2 & d2 & m_a02 & MM)). + inv STAR. + (* subcase 2 *) + { exists ([(id_cur, Bundle_call ([Event_call (comp_of f) (Genv.find_comp ge (Vptr b2 Ptrofs.zero)) i0 vl] ++ t1) i0 vl (ef_sig ef) (d'))]). eexists. split; auto. + econs 2. 2: econs 1. 2: eauto. eapply ir_step_cross_call_external2. + 8: eapply FACT8. 6: eapply FACT6. 5: eapply FACT5. 3: eapply FACT3. 2: eapply FACT2. all: eauto. + erewrite eventval_list_match_vals_to_eventvals; eauto. + } + rename H into STEP, H2 into STAR. inv STEP. ss. rewrite Pregmap.gss in *. destruct MM as [MM VAL]. + (* subcase 3 *) + pose proof WFIR0 as CUR. unfold wf_ir_cur in CUR. des_ifs. clear CUR. rename Heq1 into CUR. + unfold update_stack_return in STUPD. rewrite Pregmap.gss in STUPD. des_ifs. + { exfalso. rewrite Heq0, RSX, H0 in Heq1. ss. rewrite Pos.eqb_sym, Heq in Heq1. congruence with Heq1. } + clear PC_RA. inv EV. + { exfalso. apply H. rewrite Heq0, RSX, H0. ss. unfold Genv.type_of_call. rewrite Heq. auto. } + assert (RES: (return_value (set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (rs' X1) (ef_sig ef)) = res). + { exploit NO_CROSS_PTR0; auto. clear. intros NPTR. + unfold return_value, loc_external_result in *. remember (Conventions1.loc_result (ef_sig ef)) as rpmr. + unfold Conventions1.loc_result in Heqrpmr. des_ifs. + ss. rewrite ! (Pregmap.gso (j:=PC)) in *; ss. rewrite ! Pregmap.gss in *. rewrite Pregmap.gso, Pregmap.gss in *; ss. + unfold Val.longofwords, Val.hiword, Val.loword in *. des_ifs. + rewrite Int64.ofwords_recompose. auto. + } + eapply asm_to_ir_compose. + 2:{ instantiate (1:=t3). rewrite app_comm_cons. setoid_rewrite app_assoc. eauto. } + exists ([(id_cur, Bundle_call ([Event_call (comp_of f) (Genv.find_comp ge (Vptr b2 Ptrofs.zero)) i0 vl] ++ t1 ++ [Event_return (Genv.find_comp_ignore_offset ge (rs' X1)) (Genv.find_comp_ignore_offset ge (rs' PC)) res0]) i0 vl (ef_sig ef) (d'))]). eexists. split. + { split; auto. + { ss. rewrite app_nil_r. auto. } + econstructor 2. 2: econstructor 1. 2: eauto. eapply ir_step_cross_call_external3. + 8: eapply FACT8. 6: eapply FACT6. 5: eapply FACT5. 3: eapply NEXTF. 2: eapply FACT2. all: eauto. + { erewrite eventval_list_match_vals_to_eventvals; eauto. } + { intros. exploit NO_CROSS_PTR0; auto. rewrite RES. clear - VAL. intros. destruct VAL as [VAL | VAL]. + - pose proof Val.inject_list_not_ptr. specialize (H k2 [res] [res']). exploit H. econs; eauto. econs; eauto. intros. inv x1. auto. + - subst; auto. + } + { econs; eauto. + - setoid_rewrite MTST1. rewrite H0. ss. unfold Genv.find_comp. setoid_rewrite H1. clear - NEQCP. + unfold Genv.type_of_call. rewrite <- Pos.eqb_neq in NEQCP. setoid_rewrite NEQCP. auto. + - instantiate (1:=res0). rewrite RES in H2, NO_CROSS_PTR0. exploit NO_CROSS_PTR0; auto. intros NPTR. + clear - H2 NPTR VAL. destruct VAL as [VAL | VAL]; subst; auto. remember (proj_rettype (sig_res (ef_sig ef))) as ty. clear dependent ef. + inv VAL; ss; eauto. + - f_equal. f_equal. rewrite Heq0, RSX. rewrite MTST1, H0. ss. rewrite NEXTPC. ss. + } + } + rewrite H0 in RSX. ss. inv RSX. eapply IH. 4: eapply STAR. all: auto. + { ss. splits; auto. unfold wf_regset in *. rewrite Pregmap.gss. rewrite Heq0. rewrite H1. auto. } + { ss. splits; auto. + - unfold match_cur_regset in *. rewrite Pregmap.gss. rewrite Heq0. rewrite MTST1. rewrite H0. ss. + - eauto. + } + } + } + + - (** internal_return *) + destruct ist as [[[cur m_i] ik] |]; ss. + destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). + destruct WFASM as [WFASM0 WFASM1]. + inv STAR. + { end_case. } + rename H into STEP, H5 into STAR. + exploit exec_instr_is_return. eapply H3. auto. intros ((v & NEXTPC) & TEMP). subst m'. + eapply asm_to_ir_returnstate. 2: eapply IH. 11: eapply STAR. 10: eapply STEP. + all: eauto. + { rewrite <- REC_CURCOMP. apply MTST1. } + + - (** return *) + exfalso. unfold wf_asm in WFASM. contradiction WFASM. + + - (** builtin *) + destruct ist as [[[cur m_i] ik] |]; ss. + exploit asm_to_ir_builtin; eauto. + destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). + clear dependent k. clear dependent d. clear dependent m_a0. + intros (btr1 & k & d & m_a & m_i' & UTR1 & ISTAR1 & MEM). + eapply asm_to_ir_compose. 2: eauto. exists btr1. eexists. split. + { split; eauto. } + clear dependent btr1. clear dependent m_i. rename m_i' into m_i. + destruct WFASM as [WFASM0 WFASM1]. + remember (nextinstr (set_res (map_builtin_res preg_of res) vres (undef_regs (map preg_of (destroyed_by_builtin ef)) (rs # X1 <- Vundef) # X31 <- Vundef))) as rs'. + assert (NEXTPC: rs' PC = Val.offset_ptr (rs PC) Ptrofs.one). + { subst rs'. clear. unfold nextinstr. simpl. + rewrite Pregmap.gss. f_equal. rewrite ! Asmgenproof0.set_res_other; ss. + rewrite Asmgenproof0.undef_regs_other_2. + rewrite Pregmap.gso. rewrite Pregmap.gso. all: ss; auto. + rewrite Asmgenproof0.preg_notin_charact. intros. destruct mr; ss. + } + eapply IH. 4: eapply STAR. all: auto. + { simpl. split; auto. unfold wf_regset in *. rewrite NEXTPC, H0. simpl. rewrite H1. auto. } + { simpl. splits. 6: eapply MEM. all: auto. unfold match_cur_regset in *. + rewrite NEXTPC, H0. ss. rewrite MTST1, H0. ss. + } + + - (** external *) + exfalso. destruct WFASM as [WFASM0 WFASM1]. unfold wf_regset in WFASM1. + rewrite H0 in WFASM1. rewrite H1 in WFASM1. contradiction WFASM1. + + Qed. + +End PROOF. + +Section INIT. + + Definition wf_program {F V} (p: AST.program F V) := list_norepet (prog_defs_names p). + + Lemma wf_program_wf_ge + F V (p: AST.program F V) + (WFP: wf_program p) + : + wf_ge (Genv.globalenv p). + Proof. unfold wf_ge; eauto. Qed. + + Definition wf_main (p: Asm.program) := + exists b, (Genv.find_symbol (Genv.globalenv p) (prog_main p) = Some b) /\ + (exists f, Genv.find_funct_ptr (Genv.globalenv p) b = Some (Internal f)). + + Definition wf_main_sig (p: Asm.program) := + forall b f, (Genv.find_symbol (Genv.globalenv p) (prog_main p) = Some b) -> + (Genv.find_funct_ptr (Genv.globalenv p) b = Some (Internal f)) -> + fn_sig f = signature_main. + + Lemma wf_asm_initial_state + p ast + (WFMAIN: wf_main p) + (INIT: initial_state p ast) + : + wf_asm (Genv.globalenv p) ast. + Proof. + unfold wf_main in WFMAIN. des. inv INIT. unfold wf_asm. split. + { unfold initial_stack. ss. } + { unfold wf_regset. subst rs0. rewrite Pregmap.gso; ss. rewrite Pregmap.gso; ss. rewrite Pregmap.gss. + (* unfold fundef in *. *) + unfold Genv.symbol_address. subst ge. rewrite WFMAIN, WFMAIN0. auto. + } + Qed. + + Variant ir_initial_state (p: Asm.program): ir_state -> Prop := + | ir_initial_state_intro: forall cur m0, + let ge := Genv.globalenv p in + Genv.find_symbol ge (prog_main p) = Some cur -> + (exists f, Genv.find_funct_ptr ge cur = Some (Internal f)) -> + Genv.init_mem p = Some m0 -> + ir_initial_state p (Some (cur, m0, [])). + + Lemma ir_has_initial_state + p ast + (WFMAIN: wf_main p) + (INIT: Asm.initial_state p ast) + : + exists ist, ir_initial_state p ist. + Proof. + unfold wf_main in WFMAIN. des. inv INIT. + exists (Some (b, m0, [])). econs; eauto. + Qed. + + Lemma match_state_initial_state + p ast ist + (WFMAINSIG: wf_main_sig p) + (INITA: Asm.initial_state p ast) + (INITI: ir_initial_state p ist) + ge + (GE: ge = Genv.globalenv p) + : + exists m0 j, (Genv.init_mem p = Some m0) /\ (match_state ge j m0 [] ast ist). + Proof. + inv INITA. inv INITI. des. specialize (WFMAINSIG _ _ H0 H1). + clarify. exists m0, (Mem.flat_inj (Mem.nextblock m0)). esplits; eauto. unfold match_state. subst ge. splits. + - unfold wf_ir_cur. rewrite H1. auto. + - econs. + - unfold match_cur_stack_sig. rewrite H1. ss. + - unfold match_cur_regset. subst rs0. rewrite Pregmap.gso; ss. rewrite Pregmap.gso; ss. rewrite Pregmap.gss. + unfold Genv.symbol_address. subst ge0. rewrite H0. ss. + - econs. + - unfold match_mem. + assert (MNA: meminj_not_alloc (meminj_public (Genv.globalenv p)) m0). + { unfold meminj_not_alloc. intros. unfold meminj_public. des_ifs. exfalso. apply Senv.invert_find_symbol in Heq. exploit Genv.find_symbol_not_fresh. eauto. + eapply Heq. intros CC. unfold Mem.valid_block in CC. unfold Plt in CC. lia. + } + splits; ss; auto. + + eapply Genv.initmem_inject; eauto. + + ii. unfold meminj_public in H. unfold Mem.flat_inj. des_ifs. exfalso. + apply n; clear n. unfold Plt. destruct (Pos.ltb_spec b' (Mem.nextblock m0)); auto. + exfalso. specialize (MNA _ H). unfold meminj_public in MNA. rewrite Heq, Heq0 in MNA. clarify. + + ii. unfold meminj_public in H. des_ifs. clear - Heq Heq0 H3 H2. exploit Senv.invert_find_symbol; eauto. intros FIND. rename H2 into INITM, H3 into FREE. clear - INITM FREE FIND. + eapply Genv.find_symbol_find_def_inversion in FIND. des. destruct g. + * exploit Genv.init_mem_characterization_2; eauto. + { unfold Genv.find_funct_ptr. rewrite FIND. eauto. } + intros [CUR CC]. exploit CC. eapply FREE. intros. des; clarify. + * exploit Genv.init_mem_characterization; eauto. + { unfold Genv.find_var_info. rewrite FIND. eauto. } + intros [_ [CC [_ _]]]. exploit CC. eapply FREE. intros. des. clear - x1. unfold Genv.perm_globvar in x1. des_ifs; inv x1. + + ii. unfold meminj_public. des_ifs. intros. rewrite Z.add_0_r in H. auto. + Qed. + +End INIT. diff --git a/security/BtInfoAsmBound.v b/security/BtInfoAsmBound.v new file mode 100644 index 0000000000..f5e39c1f01 --- /dev/null +++ b/security/BtInfoAsmBound.v @@ -0,0 +1,82 @@ +Require Import String. +Require Import Coqlib Maps Errors Integers Values Memory Globalenvs. +Require Import AST Linking Smallstep Events Behaviors. + +Require Import Split. + +Require Import riscV.Machregs. +Require Import riscV.Asm. +Require Import Complements. + +Require Import Tactics. +Require Import BtBasics BtInfoAsm MemoryDelta MemoryWeak. + + + +Section AXIOM. + + Definition extcall_observable (sem: extcall_sem) (sg: signature): Prop := + forall ge vargs m1 t vres m2, + sem ge vargs m1 t vres m2 -> t <> E0. + + Definition external_functions_observable := + forall id sg, extcall_observable (external_functions_sem id sg) sg. + + Definition inline_assembly_observable := + forall cp id sg, extcall_observable (inline_assembly_sem cp id sg) sg. + + (* Axiom external_functions_observable: *) + (* forall id sg, extcall_observable (external_functions_sem id sg) sg. *) + + (* Axiom inline_assembly_observable: *) + (* forall cp id sg, extcall_observable (inline_assembly_sem cp id sg) sg. *) + +End AXIOM. + +Section BOUND. + + Hypothesis EFO: external_functions_observable. + Hypothesis IAO: inline_assembly_observable. + + Lemma external_call_observable_length + ef ge vargs m1 tr vretv m2 + (EC: external_call ef ge vargs m1 tr vretv m2) + (ECCASES : external_call_unknowns ef ge m1 vargs \/ + external_call_known_observables ef ge m1 vargs tr vretv m2) + : + (1 <= length tr)%nat. + Proof. + des. + - unfold external_functions_observable in EFO. unfold extcall_observable in EFO. + unfold inline_assembly_observable in IAO. unfold extcall_observable in IAO. + cut (tr <> E0). + { i. destruct tr; ss. lia. } + destruct ef; ss; eauto. + + unfold builtin_or_external_sem in EC. des_ifs; ss; eauto. + + unfold builtin_or_external_sem in EC. des_ifs; ss; eauto. + - destruct ef; ss; des; clarify; try (inv EC; ss). + + destruct tr; ss. lia. + + destruct tr; ss. lia. + Qed. + + Lemma bundle_trace_bounded + ge ist ist' btr + (ISTAR: istar (ir_step) ge ist btr ist') + : + (length btr <= length (unbundle_trace btr))%nat. + Proof. + induction ISTAR. ss. subst. ss. + apply Nat.succ_le_mono in IHISTAR. etransitivity. eauto. clear IHISTAR. + rewrite app_length. cut (1 <= length (unbundle ev))%nat. lia. + unfold unbundle. + inv H; ss. + - inv TR; ss. + - inv TR; ss. + - eapply external_call_observable_length; eauto. des; auto. + - eapply external_call_observable_length; eauto. des; auto. + - inv TR; ss. + - inv TR1; ss. lia. + - inv TR1; ss. lia. + Qed. + +End BOUND. diff --git a/security/MemoryDelta.v b/security/MemoryDelta.v new file mode 100644 index 0000000000..89a4326111 --- /dev/null +++ b/security/MemoryDelta.v @@ -0,0 +1,1165 @@ +Require Import String. +Require Import Coqlib Maps Errors Integers Values Memory Globalenvs. +Require Import AST Linking Smallstep Events Behaviors. +Require Import MemoryWeak. +Require Import Tactics. + +Section AUX. + + Lemma alloc_left_unmapped_winject_keep: + forall f m1 m2 c lo hi m1' b1, + winject f m1 m2 -> + Mem.alloc m1 c lo hi = (m1', b1) -> + winject f m1' m2. + Proof. + intros. set (f' := fun b => if eq_block b b1 then None else f b). + cut (winject f' m1' m2 /\ inject_incr f f' /\ f' b1 = None /\ (forall b, b <> b1 -> f' b = f b)). + { clear - f'. intros (INJ & INCR & _ & _). unfold inject_incr in INCR. + assert (f' = f). + { eapply Axioms.functional_extensionality. intros x. destruct (eq_block x b1). + - subst x. destruct (f b1) eqn:FB. + + destruct p. specialize (INCR _ _ _ FB). auto. + + subst f'. simpl. rewrite pred_dec_true; auto. + - subst f'. simpl. rewrite pred_dec_false; auto. + } + rewrite <- H. apply INJ. + } + inversion H. assert (inject_incr f f'). + red; unfold f'; intros. destruct (eq_block b b1). subst b. + assert (f b1 = None). eauto with mem. congruence. + auto. + assert (mem_winj f' m1 m2). + inversion mwi_inj; constructor; eauto with mem. + unfold f'; intros. destruct (eq_block b0 b1). congruence. eauto. + unfold f'; intros. destruct (eq_block b0 b1). congruence. eauto. + unfold f'; intros. destruct (eq_block b0 b1). congruence. + unfold f'; intros. destruct (eq_block b0 b1). congruence. + eapply mwi_align; eauto. + split. constructor. + (* inj *) + eapply alloc_left_unmapped_winj; eauto. unfold f'; apply dec_eq_true. + (* freeblocks *) + intros. unfold f'. destruct (eq_block b b1). auto. + apply mi_freeblocks. red; intro; elim H3. eauto with mem. + (* mappedblocks *) + unfold f'; intros. destruct (eq_block b b1). congruence. eauto. + (* no overlap *) + unfold f'; red; intros. + destruct (eq_block b0 b1); destruct (eq_block b2 b1); try congruence. + eapply mwi_no_overlap. eexact H3. eauto. eauto. + exploit Mem.perm_alloc_inv. eauto. eexact H6. rewrite dec_eq_false; auto. + exploit Mem.perm_alloc_inv. eauto. eexact H7. rewrite dec_eq_false; auto. + (* representable *) + unfold f'; intros. + destruct (eq_block b b1); try discriminate. + eapply mwi_representable; try eassumption. + destruct H4; eauto using Mem.perm_alloc_4. + (* perm inv *) + intros. unfold f' in H3; destruct (eq_block b0 b1); try discriminate. + exploit mwi_perm_inv; eauto. + intuition eauto using Mem.perm_alloc_1, Mem.perm_alloc_4. + (* incr *) + split. auto. + (* image *) + split. unfold f'; apply dec_eq_true. + (* incr *) + intros; unfold f'; apply dec_eq_false; auto. + Qed. + + Lemma alloc_left_unmapped_inject_keep: + forall f m1 m2 c lo hi m1' b1, + Mem.inject f m1 m2 -> + Mem.alloc m1 c lo hi = (m1', b1) -> + Mem.inject f m1' m2. + Proof. + intros. set (f' := fun b => if eq_block b b1 then None else f b). + cut (Mem.inject f' m1' m2 /\ inject_incr f f' /\ f' b1 = None /\ (forall b, b <> b1 -> f' b = f b)). + { clear - f'. intros (INJ & INCR & _ & _). unfold inject_incr in INCR. + assert (f' = f). + { eapply Axioms.functional_extensionality. intros x. destruct (eq_block x b1). + - subst x. destruct (f b1) eqn:FB. + + destruct p. specialize (INCR _ _ _ FB). auto. + + subst f'. simpl. rewrite pred_dec_true; auto. + - subst f'. simpl. rewrite pred_dec_false; auto. + } + rewrite <- H. apply INJ. + } + inversion H. assert (inject_incr f f'). + red; unfold f'; intros. destruct (eq_block b b1). subst b. + assert (f b1 = None). eauto with mem. congruence. + auto. + assert (Mem.mem_inj f' m1 m2). + inversion mi_inj; constructor; eauto with mem. + unfold f'; intros. destruct (eq_block b0 b1). congruence. eauto. + unfold f'; intros. destruct (eq_block b0 b1). congruence. eauto. + unfold f'; intros. destruct (eq_block b0 b1). congruence. + unfold f'; intros. destruct (eq_block b0 b1). congruence. + eapply mi_align; eauto. + unfold f'; intros. destruct (eq_block b0 b1). congruence. + apply memval_inject_incr with f; auto. + split. constructor. + (* inj *) + eapply Mem.alloc_left_unmapped_inj; eauto. unfold f'; apply dec_eq_true. + (* freeblocks *) + intros. unfold f'. destruct (eq_block b b1). auto. + apply mi_freeblocks. red; intro; elim H3. eauto with mem. + (* mappedblocks *) + unfold f'; intros. destruct (eq_block b b1). congruence. eauto. + (* no overlap *) + unfold f'; red; intros. + destruct (eq_block b0 b1); destruct (eq_block b2 b1); try congruence. + eapply mi_no_overlap. eexact H3. eauto. eauto. + exploit Mem.perm_alloc_inv. eauto. eexact H6. rewrite dec_eq_false; auto. + exploit Mem.perm_alloc_inv. eauto. eexact H7. rewrite dec_eq_false; auto. + (* representable *) + unfold f'; intros. + destruct (eq_block b b1); try discriminate. + eapply mi_representable; try eassumption. + destruct H4; eauto using Mem.perm_alloc_4. + (* perm inv *) + intros. unfold f' in H3; destruct (eq_block b0 b1); try discriminate. + exploit mi_perm_inv; eauto. + intuition eauto using Mem.perm_alloc_1, Mem.perm_alloc_4. + (* incr *) + split. auto. + (* image *) + split. unfold f'; apply dec_eq_true. + (* incr *) + intros; unfold f'; apply dec_eq_false; auto. + Qed. + +End AUX. + + +Section PUBINJ. + + (* Memory injection for public global symbols: visible for external calls *) + Definition meminj_public (ge: Senv.t): meminj := + fun b => match Senv.invert_symbol ge b with + | Some id => if Senv.public_symbol ge id then Some (b, 0%Z) else None + | None => None + end. + + Definition meminj_strict (j: meminj) := forall b1 b2 b' ofsd1 ofsd2, j b1 = Some (b', ofsd1) -> j b2 = Some (b', ofsd2) -> b1 = b2. + + Lemma meminj_public_strict ge: meminj_strict (meminj_public ge). + Proof. + unfold meminj_strict. intros. unfold meminj_public in *; simpl in *. + destruct (Senv.invert_symbol ge b1) eqn:INV1. 2: congruence. destruct (Senv.public_symbol ge i) eqn:PUB1. 2: congruence. inv H. + destruct (Senv.invert_symbol ge b2) eqn:INV2. 2: congruence. destruct (Senv.public_symbol ge i0) eqn:PUB2. 2: congruence. inv H0. + auto. + Qed. + +End PUBINJ. + +Section MEMDELTA. + + (** Memory delta data and apply *) + + (* Data to get injection by invoking correct Mem.store: inj + (apply delta) = inj *) + Definition mem_delta_storev := (memory_chunk * val * val * compartment)%type. + Definition mem_delta_store := (memory_chunk * block * Z * val * compartment)%type. + Definition mem_delta_bytes := (block * Z * (list memval) * compartment)%type. + Definition mem_delta_alloc := (compartment * Z * Z)%type. + Definition mem_delta_free := (block * Z * Z * compartment)%type. + + Inductive mem_delta_kind := + | mem_delta_kind_storev (d: mem_delta_storev) + | mem_delta_kind_store (d: mem_delta_store) + | mem_delta_kind_bytes (d: mem_delta_bytes) + | mem_delta_kind_alloc (d: mem_delta_alloc) + | mem_delta_kind_free (d: mem_delta_free) + . + + (* order: old to new *) + Definition mem_delta := list mem_delta_kind. + + Definition mem_delta_apply_storev (om: option mem) (d: mem_delta_storev): option mem := + let '(ch, ptr, v, cp) := d in + match om with + | Some m => Mem.storev ch m ptr v cp + | None => None + end. + + Lemma mem_delta_apply_storev_none + d + : + mem_delta_apply_storev None d = None. + Proof. unfold mem_delta_apply_storev. destruct d as [[[d0 d2] d3] d4]. auto. Qed. + + Definition mem_delta_apply_store (om: option mem) (d: mem_delta_store): option mem := + let '(ch, b, ofs, v, cp) := d in + match om with + | Some m => Mem.store ch m b ofs v cp + | None => None + end. + + Lemma mem_delta_apply_store_none + d + : + mem_delta_apply_store None d = None. + Proof. unfold mem_delta_apply_store. destruct d as [[[[d0 d1] d2] d3] d4]. auto. Qed. + + Definition mem_delta_apply_bytes (om: option mem) (d: mem_delta_bytes): option mem := + let '(b, ofs, mvs, cp) := d in + match om with + | Some m => Mem.storebytes m b ofs mvs cp + | None => None + end. + + Lemma mem_delta_apply_bytes_none + d + : + mem_delta_apply_bytes None d = None. + Proof. unfold mem_delta_apply_bytes. destruct d as [[[d0 d1] d2] d3]. auto. Qed. + + Definition mem_delta_apply_alloc (om: option mem) (d: mem_delta_alloc): option mem := + let '(cp, lo, hi) := d in + match om with + | Some m => Some (fst (Mem.alloc m cp lo hi)) + | None => None + end. + + Lemma mem_delta_apply_alloc_none + d + : + mem_delta_apply_alloc None d = None. + Proof. unfold mem_delta_apply_alloc. destruct d as [[d0 d1] d2]. auto. Qed. + + Definition mem_delta_apply_free (om: option mem) (d: mem_delta_free): option mem := + let '(b, lo, hi, cp) := d in + match om with + | Some m => Mem.free m b lo hi cp + | None => None + end. + + Lemma mem_delta_apply_free_none + d + : + mem_delta_apply_free None d = None. + Proof. unfold mem_delta_apply_free. destruct d as [[[d0 d1] d2] d3]. auto. Qed. + + Definition mem_delta_apply_kind (data: mem_delta_kind) (om: option mem) : option mem := + match data with + | mem_delta_kind_storev d => mem_delta_apply_storev om d + | mem_delta_kind_store d => mem_delta_apply_store om d + | mem_delta_kind_bytes d => mem_delta_apply_bytes om d + | mem_delta_kind_alloc d => mem_delta_apply_alloc om d + | mem_delta_kind_free d => mem_delta_apply_free om d + end. + + Definition mem_delta_apply (d: mem_delta) (om0: option mem) : option mem := + fold_left (fun om data => mem_delta_apply_kind data om) d om0. + + Lemma mem_delta_apply_cons + d m0 k + : + mem_delta_apply (k :: d) m0 = + match k with + | mem_delta_kind_storev dd => mem_delta_apply d (mem_delta_apply_storev (m0) dd) + | mem_delta_kind_store dd => mem_delta_apply d (mem_delta_apply_store (m0) dd) + | mem_delta_kind_bytes dd => mem_delta_apply d (mem_delta_apply_bytes (m0) dd) + | mem_delta_kind_alloc dd => mem_delta_apply d (mem_delta_apply_alloc (m0) dd) + | mem_delta_kind_free dd => mem_delta_apply d (mem_delta_apply_free (m0) dd) + end. + Proof. simpl. destruct k; auto. Qed. + + Lemma mem_delta_apply_app + d0 d1 m0 + : + mem_delta_apply (d0 ++ d1) m0 = mem_delta_apply d1 (mem_delta_apply d0 m0). + Proof. + revert d1 m0. induction d0; intros. + { simpl. auto. } + rewrite <- app_comm_cons. rewrite ! mem_delta_apply_cons. destruct a; auto. + Qed. + + Lemma mem_delta_apply_none + d + : + mem_delta_apply d None = None. + Proof. + induction d; auto. rewrite mem_delta_apply_cons. + destruct a; + [rewrite mem_delta_apply_storev_none | rewrite mem_delta_apply_store_none | rewrite mem_delta_apply_bytes_none | rewrite mem_delta_apply_alloc_none | rewrite mem_delta_apply_free_none]; rewrite IHd; auto. + Qed. + + Lemma mem_delta_apply_some + d om m' + (APPD: mem_delta_apply d om = Some m') + : + exists m, om = Some m. + Proof. destruct om; eauto. rewrite mem_delta_apply_none in APPD. inv APPD. Qed. + +End MEMDELTA. + + +Section WFDELTA. + (** only wf delta is applied for back transltation *) + + (* Refer to encode_val *) + Definition wf_chunk_val_b (ch: memory_chunk) (v: val) := + match v with + | Vundef => false + | Vint n => + match ch with + | Mint8signed | Mint8unsigned => true + | Mint16signed | Mint16unsigned => true + | Mint32 => true + | _ => false + end + | Vlong n => + match ch with + | Mint64 => true + | Many32 => false + | Many64 => false + | _ => false + end + | Vfloat n => + match ch with + | Mfloat64 => true + | Many32 => false + | Many64 => false + | _ => false + end + | Vsingle n => + match ch with + | Mfloat32 => true + | Many32 => false + | Many64 => false + | _ => false + end + | Vptr _ _ => false + end. + + Definition wf_mem_delta_storev_b (ge: Senv.t) (cp0: compartment) (d: mem_delta_storev) := + let '(ch, ptr, v, cp) := d in + match ptr with + | Vptr b ofs => match Senv.invert_symbol ge b with + | Some id => (Senv.public_symbol ge id) && (wf_chunk_val_b ch v) && (Pos.eqb cp0 cp) + | _ => false + end + | _ => false + end. + + Definition wf_mem_delta_kind_b (ge: Senv.t) cp0 (d: mem_delta_kind) := + match d with | mem_delta_kind_storev dd => wf_mem_delta_storev_b ge cp0 dd | _ => false end. + + Definition get_wf_mem_delta (ge: Senv.t) cp0 (d: mem_delta): mem_delta := + filter (wf_mem_delta_kind_b ge cp0) d. + + Lemma get_wf_mem_delta_cons + ge cp0 d k + : + get_wf_mem_delta ge cp0 (k :: d) = + if (wf_mem_delta_kind_b ge cp0 k) then k :: (get_wf_mem_delta ge cp0 d) else (get_wf_mem_delta ge cp0 d). + Proof. ss. Qed. + + Lemma get_wf_mem_delta_app + ge cp0 d0 d1 + : + get_wf_mem_delta ge cp0 (d0 ++ d1) = (get_wf_mem_delta ge cp0 d0) ++ (get_wf_mem_delta ge cp0 d1). + Proof. apply filter_app. Qed. + + + Definition mem_delta_apply_wf ge cp0 (d: mem_delta) (om0: option mem): option mem := + mem_delta_apply (get_wf_mem_delta ge cp0 d) om0. + + Lemma mem_delta_apply_wf_cons + ge cp0 d m0 k + : + mem_delta_apply_wf ge cp0 (k :: d) m0 = + if (wf_mem_delta_kind_b ge cp0 k) then mem_delta_apply_wf ge cp0 d (mem_delta_apply_kind k m0) else mem_delta_apply_wf ge cp0 d m0. + Proof. unfold mem_delta_apply_wf at 1. rewrite get_wf_mem_delta_cons. des_ifs. Qed. + + Lemma mem_delta_apply_wf_app + ge cp0 d0 d1 m0 + : + mem_delta_apply_wf ge cp0 (d0 ++ d1) m0 = + mem_delta_apply_wf ge cp0 d1 (mem_delta_apply_wf ge cp0 d0 m0). + Proof. unfold mem_delta_apply_wf. rewrite get_wf_mem_delta_app. apply mem_delta_apply_app. Qed. + + Lemma mem_delta_apply_wf_none + ge cp0 d + : + mem_delta_apply_wf ge cp0 d None = None. + Proof. unfold mem_delta_apply_wf. apply mem_delta_apply_none. Qed. + + Lemma mem_delta_apply_wf_some + ge cp0 d m0 m1 + (APPD: mem_delta_apply_wf ge cp0 d m0 = Some m1) + : + exists m, m0 = Some m. + Proof. unfold mem_delta_apply_wf in APPD. exploit mem_delta_apply_some; eauto. Qed. + +End WFDELTA. + + +Section PROPS. + + (** Delta and location relations *) + + Let mcps := PTree.t compartment. + + Definition mem_delta_unchanged_storev (d: mem_delta_storev) (b': block) (ofs': Z): Prop := + let '(ch, ptr, v, cp) := d in + match ptr with + | Vptr b ofs0 => let ofs := (Ptrofs.unsigned ofs0) in (b = b') -> (ofs > ofs' \/ ofs + (size_chunk ch) <= ofs') + | _ => True + end. + + Lemma mem_delta_unchanged_on_storev + d m m' + (APPD: mem_delta_apply_storev (Some m) d = (Some m')) + : + Mem.unchanged_on (fun b ofs => mem_delta_unchanged_storev d b ofs) m m'. + Proof. + destruct d as (((ch & ptr) & v) & cp). ss. unfold Mem.storev in APPD. des_ifs. + eapply Mem.store_unchanged_on. eauto. intros. intros CONTRA. specialize (CONTRA eq_refl). lia. + Qed. + + Definition mem_delta_unchanged_store (d: mem_delta_store) (b': block) (ofs': Z): Prop := + let '(ch, b, ofs, v, cp) := d in (b = b') -> (ofs > ofs' \/ ofs + (size_chunk ch) <= ofs'). + + Lemma mem_delta_unchanged_on_store + d m m' + (APPD: mem_delta_apply_store (Some m) d = (Some m')) + : + Mem.unchanged_on (fun b ofs => mem_delta_unchanged_store d b ofs) m m'. + Proof. + destruct d as ((((ch & b) & ofs) & v) & cp). ss. + eapply Mem.store_unchanged_on. eauto. intros. intros CONTRA. specialize (CONTRA eq_refl). lia. + Qed. + + Definition mem_delta_unchanged_bytes (d: mem_delta_bytes) (b': block) (ofs': Z): Prop := + let '(b, ofs, mvs, cp) := d in + (b = b') -> (ofs > ofs' \/ ofs + Z.of_nat (Datatypes.length mvs) <= ofs'). + + Lemma mem_delta_unchanged_on_bytes + d m m' + (APPD: mem_delta_apply_bytes (Some m) d = (Some m')) + : + Mem.unchanged_on (fun b ofs => mem_delta_unchanged_bytes d b ofs) m m'. + Proof. + destruct d as (((b & ofs) & mvs) & cp). simpl in *. + eapply Mem.storebytes_unchanged_on. eauto. intros. intros CONTRA. specialize (CONTRA eq_refl). lia. + Qed. + + Definition mem_delta_unchanged_alloc (d: mem_delta_alloc) (b': block) (ofs': Z): Prop := + let '(cp, lo, hi) := d in + True. + + Lemma mem_delta_unchanged_on_alloc + d m m' + (APPD: mem_delta_apply_alloc (Some m) d = (Some m')) + : + Mem.unchanged_on (fun b ofs => mem_delta_unchanged_alloc d b ofs) m m'. + Proof. + destruct d as ((cp & lo) & hi). simpl in *. destruct (Mem.alloc m cp lo hi) eqn:ALLOC; simpl in *. inv APPD. + eapply Mem.alloc_unchanged_on. eauto. + Qed. + + Definition mem_delta_unchanged_free (d: mem_delta_free) (b': block) (ofs': Z): Prop := + let '(b, lo, hi, cp) := d in + (b = b') -> (lo > ofs' \/ hi <= ofs'). + + Lemma mem_delta_unchanged_on_free + d m m' + (APPD: mem_delta_apply_free (Some m) d = (Some m')) + : + Mem.unchanged_on (fun b ofs => mem_delta_unchanged_free d b ofs) m m'. + Proof. + destruct d as (((b & lo) & hi) & cp). simpl in *. + eapply Mem.free_unchanged_on. eauto. intros. intros CONTRA. specialize (CONTRA eq_refl). lia. + Qed. + + Definition mem_delta_kind_unchanged (k: mem_delta_kind) (b: block) (ofs: Z) := + match k with + | mem_delta_kind_storev dd => mem_delta_unchanged_storev dd b ofs + | mem_delta_kind_store dd => mem_delta_unchanged_store dd b ofs + | mem_delta_kind_bytes dd => mem_delta_unchanged_bytes dd b ofs + | mem_delta_kind_alloc dd => mem_delta_unchanged_alloc dd b ofs + | mem_delta_kind_free dd => mem_delta_unchanged_free dd b ofs + end. + + Definition mem_delta_unchanged (d: mem_delta) (b: block) (ofs: Z) := + Forall (fun k => mem_delta_kind_unchanged k b ofs) d. + + Lemma mem_delta_unchanged_on + d m m' + (APPD: mem_delta_apply d (Some m) = Some m') + : + Mem.unchanged_on (fun b ofs => mem_delta_unchanged d b ofs) m m'. + Proof. + revert m m' APPD. induction d; intros; simpl. + { simpl in APPD. inv APPD. apply Mem.unchanged_on_refl. } + rewrite mem_delta_apply_cons in APPD. destruct a. + - destruct d0 as [[[ch ptr] v] cp]. destruct (mem_delta_apply_storev (Some m) (ch, ptr, v, cp)) eqn:MEM. + 2:{ rewrite mem_delta_apply_none in APPD. inv APPD. } + specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. + 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H. auto. } + { eapply Mem.unchanged_on_implies. eapply mem_delta_unchanged_on_storev. eauto. + intros. simpl. des_ifs. intros; subst. inv H. simpl in H3. specialize (H3 eq_refl). auto. + } + - destruct d0 as [[[[ch b] ofs] v] cp]. destruct (mem_delta_apply_store (Some m) (ch, b, ofs, v, cp)) eqn:MEM. + 2:{ rewrite mem_delta_apply_none in APPD. inv APPD. } + specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. + 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H. auto. } + { eapply Mem.unchanged_on_implies. eapply mem_delta_unchanged_on_store. eauto. + intros. simpl. intros; subst. inv H. simpl in H3. specialize (H3 eq_refl). auto. + } + - destruct d0 as [[[b ofs] mvs] cp]. destruct (mem_delta_apply_bytes (Some m) (b, ofs, mvs, cp)) eqn:MEM. + 2:{ rewrite mem_delta_apply_none in APPD. inv APPD. } + specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. + 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H. auto. } + { eapply Mem.unchanged_on_implies. eapply mem_delta_unchanged_on_bytes. eauto. + intros. simpl. intros; subst. inv H. simpl in H3. specialize (H3 eq_refl). auto. + } + - destruct d0 as [[cp lo] hi]. destruct (mem_delta_apply_alloc (Some m) (cp, lo, hi)) eqn:MEM. + 2:{ rewrite mem_delta_apply_none in APPD. inv APPD. } + specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. + 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H. auto. } + { eapply Mem.unchanged_on_implies. eapply mem_delta_unchanged_on_alloc. eauto. + intros. simpl. auto. + } + - destruct d0 as [[[b lo] hi] cp]. destruct (mem_delta_apply_free (Some m) (b, lo, hi, cp)) eqn:MEM. + 2:{ rewrite mem_delta_apply_none in APPD. inv APPD. } + specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. + 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H. auto. } + { eapply Mem.unchanged_on_implies. eapply mem_delta_unchanged_on_free. eauto. + intros. simpl. intros; subst. inv H. simpl in H3. specialize (H3 eq_refl). auto. + } + Qed. + + Lemma mem_delta_wf_unchanged_on + ge cp d m m' + (APPD: mem_delta_apply_wf ge cp d (Some m) = Some m') + : + Mem.unchanged_on (fun b ofs => mem_delta_unchanged (get_wf_mem_delta ge cp d) b ofs) m m'. + Proof. eapply mem_delta_unchanged_on; eauto. Qed. + + Lemma get_from_setN_same_upto_ofs + ofs0 ofs l ofsd + (OFS: ofs0 <= ofs < ofs0 + Z.of_nat (Datatypes.length l)) + (mc1 mc2 : (ZMap.t memval)) + : + ZMap.get ofs (Mem.setN l ofs0 mc1) = ZMap.get (ofs + ofsd) (Mem.setN l (ofs0 + ofsd) mc2). + Proof. + revert ofs0 ofs ofsd OFS mc1 mc2. induction l; simpl; intros. + { lia. } + destruct (Z.eqb_spec ofs0 ofs). + { subst ofs0. clear OFS. rewrite ! Mem.setN_outside; try lia. rewrite ! ZMap.gss. auto. } + { replace (ofs0 + ofsd + 1) with ((ofs0 + 1) + ofsd) by lia. eapply IHl. lia. } + Qed. + + Lemma get_from_setN_same + ofs0 ofs l + (OFS: ofs0 <= ofs < ofs0 + Z.of_nat (Datatypes.length l)) + (mc1 mc2 : (ZMap.t memval)) + : + ZMap.get ofs (Mem.setN l ofs0 mc1) = ZMap.get ofs (Mem.setN l ofs0 mc2). + Proof. + replace ofs with (ofs + 0) at 2 by lia. replace ofs0 with (ofs0 + 0) at 2 by lia. eapply get_from_setN_same_upto_ofs; auto. + Qed. + + Lemma mem_store_same_upto_ofs + ofs ofs0 ch0 v0 cp0 ofsd b b' m1 m2 m1' m2' + (OFS: ofs0 <= ofs < ofs0 + size_chunk ch0) + (MEM1: Mem.store ch0 m1 b ofs0 v0 cp0 = Some m1') + (MEM2: Mem.store ch0 m2 b' (ofs0 + ofsd) v0 cp0 = Some m2') + : + ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get (ofs + ofsd) (Mem.mem_contents m2') !! b'. + Proof. + apply Mem.store_mem_contents in MEM1, MEM2. rewrite MEM1, MEM2. rewrite ! PMap.gss. + rewrite size_chunk_conv, <- (encode_val_length ch0 v0) in OFS. + remember (encode_val ch0 v0) as l. remember (Mem.mem_contents m1) as mc1. remember (Mem.mem_contents m2) as mc2. clear - OFS. + eapply get_from_setN_same_upto_ofs. auto. + Qed. + + + Definition mem_delta_changed_storev (d: mem_delta_storev) (b': block) (ofs': Z): Prop := + let '(ch, ptr, v, cp) := d in + match ptr with + | Vptr b ofs0 => let ofs := Ptrofs.unsigned ofs0 in (b = b') /\ (ofs <= ofs' < ofs + (size_chunk ch)) + | _ => False + end. + + Lemma mem_delta_changed_storev_same + d b ofs + (CHG: mem_delta_changed_storev d b ofs) + m1 m1' m2 m2' + (APPD1: mem_delta_apply_storev (Some m1) d = Some m1') + (APPD2: mem_delta_apply_storev (Some m2) d = Some m2') + : + ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. + Proof. + destruct d as [[[ch0 ptr0] v0] cp0]. unfold mem_delta_changed_storev in CHG. des_ifs. + destruct CHG as (BLK & OFS). subst b0. + simpl in *. replace ofs with (ofs + 0) at 2 by lia. eapply mem_store_same_upto_ofs; eauto. + rewrite Z.add_0_r. eauto. + Qed. + + Definition mem_delta_changed_store (d: mem_delta_store) (b': block) (ofs': Z): Prop := + let '(ch, b, ofs, v, cp) := d in + (b = b') /\ (ofs <= ofs' < ofs + (size_chunk ch)). + + Lemma mem_delta_changed_store_same + d b ofs + (CHG: mem_delta_changed_store d b ofs) + m1 m1' m2 m2' + (APPD1: mem_delta_apply_store (Some m1) d = Some m1') + (APPD2: mem_delta_apply_store (Some m2) d = Some m2') + : + ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. + Proof. + destruct d as [[[[ch0 b0] ofs0] v0] cp0]. destruct CHG as (BLK & OFS). subst b0. + simpl in *. replace ofs with (ofs + 0) at 2 by lia. eapply mem_store_same_upto_ofs; eauto. + replace (ofs0 + 0) with ofs0 by lia. eauto. + Qed. + + Definition mem_delta_changed_bytes (d: mem_delta_bytes) (b': block) (ofs': Z): Prop := + let '(b, ofs, mvs, cp) := d in + (b = b') /\ (ofs <= ofs' < ofs + Z.of_nat (Datatypes.length mvs)). + + Lemma mem_delta_changed_bytes_same + d b ofs + (CHG: mem_delta_changed_bytes d b ofs) + m1 m1' m2 m2' + (APPD1: mem_delta_apply_bytes (Some m1) d = Some m1') + (APPD2: mem_delta_apply_bytes (Some m2) d = Some m2') + : + ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. + Proof. + destruct d as [[[b0 ofs0] mvs0] cp0]. destruct CHG as (BLK & OFS). subst b0. + simpl in *. apply Mem.storebytes_mem_contents in APPD1, APPD2. rewrite APPD1, APPD2. rewrite ! PMap.gss. + eapply get_from_setN_same. auto. + Qed. + + Definition mem_delta_changed_alloc (d: mem_delta_alloc) (b': block) (ofs': Z): Prop := + let '(cp, lo, hi) := d in + False. + + Lemma mem_delta_changed_alloc_same + d b ofs + (CHG: mem_delta_changed_alloc d b ofs) + m1 m1' m2 m2' + (APPD1: mem_delta_apply_alloc (Some m1) d = Some m1') + (APPD2: mem_delta_apply_alloc (Some m2) d = Some m2') + : + ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. + Proof. + unfold mem_delta_changed_alloc in CHG. destruct d. destruct p. inv CHG. + Qed. + + Definition mem_delta_changed_free (d: mem_delta_free) (b': block) (ofs': Z): Prop := + let '(b, lo, hi, cp) := d in + (b = b') /\ (lo <= ofs' < hi). + + Definition mem_delta_kind_changed (k: mem_delta_kind) (b: block) (ofs: Z) := + match k with + | mem_delta_kind_storev dd => mem_delta_changed_storev dd b ofs + | mem_delta_kind_store dd => mem_delta_changed_store dd b ofs + | mem_delta_kind_bytes dd => mem_delta_changed_bytes dd b ofs + | mem_delta_kind_alloc dd => mem_delta_changed_alloc dd b ofs + | mem_delta_kind_free dd => mem_delta_changed_free dd b ofs + end. + + Definition mem_delta_changed (d: mem_delta) (b: block) (ofs: Z) := + Exists (fun k => mem_delta_kind_changed k b ofs) d. + + + (** Propperties *) + Lemma mem_delta_cases_storev + d b ofs + : + mem_delta_unchanged_storev d b ofs \/ mem_delta_changed_storev d b ofs. + Proof. destruct d as [[[ch0 ptr0] v0] cp0]. ss. des_ifs; auto. lia. Qed. + + Lemma mem_delta_cases_store + d b ofs + : + mem_delta_unchanged_store d b ofs \/ mem_delta_changed_store d b ofs. + Proof. destruct d as [[[[ch0 b0] ofs0] v0] cp0]. simpl. lia. Qed. + + Lemma mem_delta_cases_bytes + d b ofs + : + mem_delta_unchanged_bytes d b ofs \/ mem_delta_changed_bytes d b ofs. + Proof. destruct d as [[[b0 ofs0] mvs] cp0]. simpl. lia. Qed. + + Lemma mem_delta_cases_alloc + d b ofs + : + mem_delta_unchanged_alloc d b ofs \/ mem_delta_changed_alloc d b ofs. + Proof. destruct d as [[x y] z]. simpl. auto. Qed. + + Lemma mem_delta_cases_free + d b ofs + : + mem_delta_unchanged_free d b ofs \/ mem_delta_changed_free d b ofs. + Proof. destruct d as [[[b0 lo] hi] cp0]. simpl. lia. Qed. + + Lemma mem_delta_cases_kind + d b ofs + : + mem_delta_kind_unchanged d b ofs \/ mem_delta_kind_changed d b ofs. + Proof. destruct d; simpl. apply mem_delta_cases_storev. apply mem_delta_cases_store. apply mem_delta_cases_bytes. apply mem_delta_cases_alloc. apply mem_delta_cases_free. Qed. + + Lemma mem_delta_unchanged_or_changed + d b ofs + : + mem_delta_unchanged d b ofs \/ mem_delta_changed d b ofs. + Proof. + induction d. + { left. constructor 1. } + destruct IHd. + 2:{ right. constructor 2. auto. } + destruct (mem_delta_cases_kind a b ofs). + - left. constructor; auto. + - right. constructor 1; auto. + Qed. + +End PROPS. + +Section PROOFS. + (** Props for proofs *) + + Definition mem_delta_kind_inj_wf (cp0: compartment) (j: meminj): mem_delta_kind -> Prop := + fun data => + match data with + | mem_delta_kind_storev (ch, ptr, v, cp) => cp = cp0 + | mem_delta_kind_store (ch, b, ofs, v, cp) => (j b) = None + | mem_delta_kind_bytes (b, ofs, mvs, cp) => (j b) = None + | mem_delta_kind_free (b, lo, hi, cp) => (j b) = None + | _ => True + end. + + Definition mem_delta_inj_wf cp (j: meminj): mem_delta -> Prop := + fun d => Forall (fun data => mem_delta_kind_inj_wf cp j data) d. + + Definition meminj_first_order (j: meminj) (m: mem) := + forall b ofs, (j b <> None) -> (Mem.perm m b ofs Cur Readable) -> loc_first_order m b ofs. + + Definition meminj_not_alloc (j: meminj) (m: mem) := forall b, (Mem.nextblock m <= b)%positive -> j b = None. + + + Lemma mem_storev_first_order_wf_chunk_val + ch m b i v cp m' + (MEM: Mem.storev ch m (Vptr b i) v cp = Some m') + ofs + (FO: loc_first_order m' b ofs) + (CHG: Ptrofs.unsigned i <= ofs < Ptrofs.unsigned i + size_chunk ch) + : + wf_chunk_val_b ch v. + Proof. + unfold loc_first_order in FO. ss. exploit Mem.store_mem_contents; eauto. intros CNT. + rewrite CNT in FO. remember (Ptrofs.unsigned i) as ofs0. rewrite PMap.gss in FO. remember ((Mem.mem_contents m) !! b) as mcv. clear - FO CHG. + assert (IN: In (ZMap.get ofs (Mem.setN (encode_val ch v) ofs0 mcv)) (encode_val ch v)). + { eapply Mem.setN_in. rewrite encode_val_length. rewrite <- size_chunk_conv. auto. } + remember (ZMap.get ofs (Mem.setN (encode_val ch v) ofs0 mcv)) as mv. clear - FO IN. + destruct ch; destruct v; ss; des; clarify. + 1,2: des_ifs; ss; des; clarify. + Qed. + + Lemma list_forall_filter + A (P: A -> Prop) l B + (FA: Forall P l) + : + Forall P (filter B l). + Proof. induction FA; ss. des_ifs. econs; eauto. Qed. + + Lemma mem_delta_unchanged_implies_wf_unchanged + ge cp d b ofs + (UNCHG: mem_delta_unchanged d b ofs) + : + mem_delta_unchanged (get_wf_mem_delta ge cp d) b ofs. + Proof. eapply list_forall_filter; eauto. Qed. + + Lemma mem_delta_changed_only_by_storev + ge cp d b ofs + (WF: mem_delta_inj_wf cp (meminj_public ge) d) + (INJ: (meminj_public ge) b <> None) + (CHG: mem_delta_changed d b ofs) + m1 m1' m2 m2' + (APPD1: mem_delta_apply d (Some m1) = Some m1') + (APPD2: mem_delta_apply_wf ge cp d (Some m2) = Some m2') + (PERM1: Mem.perm m1 b ofs Cur Readable) + (PERM2: Mem.perm m2 b ofs Cur Readable) + (FO: loc_first_order m1' b ofs) + : + ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. + Proof. + revert WF CHG m1 m1' m2 m2' APPD1 APPD2 PERM1 PERM2 FO. induction d; intros. + { inv CHG. } + rewrite mem_delta_apply_cons in APPD1. rewrite mem_delta_apply_wf_cons in APPD2. inv WF. rename H1 into WF1, H2 into WF2. inv CHG. + (* not chagned by the head *) + 2:{ specialize (IHd WF2 H0). destruct a. + - destruct d0 as [[[ch0 ptr0] v0] cp0]. des_ifs. + + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. + exploit mem_delta_apply_wf_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. + ss. unfold Mem.storev in MEM1. des_ifs. ss. eapply IHd; eauto. 1,2: eapply Mem.perm_store_1; eauto. + + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. + exploit mem_delta_apply_wf_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. + ss. unfold Mem.storev in MEM1. destruct ptr0; ss; clarify. eapply IHd; eauto. eapply Mem.perm_store_1; eauto. + - destruct d0 as [[[[ch0 b0 ]ofs0] v0] cp0]. des_ifs. + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. + ss. eapply IHd; eauto. eapply Mem.perm_store_1; eauto. + - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[[w x] y] z]. simpl in *. eapply IHd; eauto. + eapply Mem.perm_storebytes_1; eauto. + - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[x y] z]. simpl in *. eapply IHd; eauto. + destruct (Mem.alloc m1 x y z) eqn: ALLOC. ss. inv MEM1. eapply Mem.perm_alloc_1; eauto. + - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[[w x] y] z]. simpl in *. eapply IHd; eauto. + eapply Mem.perm_free_1; eauto. left. ii. subst w. clarify. + } + rename H0 into CHG. destruct (mem_delta_unchanged_or_changed d b ofs). + (* overwrite by the tail *) + 2:{ specialize (IHd WF2 H). destruct a. + - destruct d0 as [[[ch0 ptr0] v0] cp0]. des_ifs. + + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. + exploit mem_delta_apply_wf_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. + ss. unfold Mem.storev in MEM1. des_ifs. ss. eapply IHd; eauto. 1,2: eapply Mem.perm_store_1; eauto. + + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. + exploit mem_delta_apply_wf_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. + ss. unfold Mem.storev in MEM1. destruct ptr0; ss; clarify. eapply IHd; eauto. eapply Mem.perm_store_1; eauto. + - destruct d0 as [[[[ch0 b0 ]ofs0] v0] cp0]. des_ifs. + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. + ss. eapply IHd; eauto. eapply Mem.perm_store_1; eauto. + - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[[w x] y] z]. simpl in *. eapply IHd; eauto. + eapply Mem.perm_storebytes_1; eauto. + - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[x y] z]. simpl in *. eapply IHd; eauto. + destruct (Mem.alloc m1 x y z) eqn: ALLOC. ss. + - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. destruct d0 as [[[w x] y] z]. simpl in *. eapply IHd; eauto. + eapply Mem.perm_free_1; eauto. left. ii. subst w. clarify. + } + rename H into UNCHG. clear IHd. + { destruct a. + 2,3,5: ss; des_ifs; ss; des; clarify. + 2:{ destruct d0 as [[x y] z]. ss. } + destruct d0 as [[[ch0 ptr0] v0] cp0]. ss. destruct ptr0; ss. des; clarify. + assert (exists id, Senv.invert_symbol ge b = Some id /\ Senv.public_symbol ge id). + { clear - INJ. unfold meminj_public in INJ. des_ifs. eauto. } + des. rename H into INV, H0 into PUB. rewrite INV, PUB in APPD2. + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. + eapply mem_delta_unchanged_on in APPD1. exploit (Mem.unchanged_on_contents _ _ _ APPD1 b ofs); auto. + { eapply Mem.perm_store_1; eauto. } + intros H. rewrite H. + assert (FO2: loc_first_order mi1 b ofs). + { unfold loc_first_order in *. rewrite <- H. auto. } + exploit mem_storev_first_order_wf_chunk_val. 2,3: eauto. ss. eauto. + intros WFCV. rewrite WFCV in APPD2. rewrite Pos.eqb_refl in APPD2. des_ifs. + exploit mem_delta_apply_wf_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. + eapply mem_delta_wf_unchanged_on in APPD2; auto. exploit (Mem.unchanged_on_contents _ _ _ APPD2 b ofs); auto. + { eapply mem_delta_unchanged_implies_wf_unchanged; eauto. } + { eapply Mem.perm_store_1; eauto. } + intros H0. rewrite H0. replace ofs with (ofs + 0)%Z at 2 by lia. + eapply mem_store_same_upto_ofs; eauto. rewrite Z.add_0_r. eauto. + } + Qed. + + Lemma store_left_mapped_winj: + forall f chunk m1 b1 ofs v1 cp n1 m2 b2 delta, + mem_winj f m1 m2 -> + Mem.store chunk m1 b1 ofs v1 cp = Some n1 -> + f b1 = Some (b2, delta) -> + mem_winj f n1 m2. + Proof. + intros. + inv H. constructor. + (* perm *) + intros. eapply mwi_perm; eauto. eapply Mem.perm_store_2; eauto. + (* own *) + intros. eapply mwi_own. eauto. apply (proj2 (Mem.store_can_access_block_inj _ _ _ _ _ _ _ H0 _ _)). auto. + (* align *) + intros. eapply mwi_align with (ofs := ofs0) (p := p); eauto. red; intros; eauto with mem. + Qed. + + Lemma store_left_mapped_winject: + forall f chunk m1 b1 ofs v1 cp n1 m2 b2 delta, + winject f m1 m2 -> + Mem.store chunk m1 b1 ofs v1 cp = Some n1 -> + f b1 = Some (b2, delta) -> + winject f n1 m2. + Proof. + intros. inversion H. exploit store_left_mapped_winj; eauto. intros MI. constructor. + (* winj *) + auto. + (* freeblocks *) + eauto with mem. + (* mappedblocks *) + eauto with mem. + (* no overlap *) + red; intros. eauto with mem. + (* representable *) + intros. eapply mwi_representable; try eassumption. + destruct H3; eauto with mem. + (* perm inv *) + intros. exploit mwi_perm_inv; eauto using Mem.perm_store_2. + intuition eauto using Mem.perm_store_1, Mem.perm_store_2. + Qed. + + Lemma store_left_winject: + forall f chunk m1 b1 ofs v1 cp n1 m2, + winject f m1 m2 -> + Mem.store chunk m1 b1 ofs v1 cp = Some n1 -> + winject f n1 m2. + Proof. + intros. destruct (f b1) eqn:FB. + - destruct p. eapply store_left_mapped_winject; eauto. + - eapply store_unmapped_winject; eauto. + Qed. + + Lemma storebytes_left_mapped_winj: + forall f m1 b1 ofs v1 cp n1 m2 b2 delta, + mem_winj f m1 m2 -> + Mem.storebytes m1 b1 ofs v1 cp = Some n1 -> + f b1 = Some (b2, delta) -> + mem_winj f n1 m2. + Proof. + intros. + inv H. constructor. + (* perm *) + intros. eapply mwi_perm; eauto. eapply Mem.perm_storebytes_2; eauto. + (* own *) + intros. eapply mwi_own; eauto. eapply Mem.storebytes_can_access_block_inj_2; eauto. + (* align *) + intros. eapply mwi_align with (ofs := ofs0) (p := p); eauto. + red; intros. eapply Mem.perm_storebytes_2; eauto. + Qed. + + Lemma storebytes_left_mapped_winject: + forall f m1 b1 ofs v1 cp n1 m2 b2 delta, + winject f m1 m2 -> + Mem.storebytes m1 b1 ofs v1 cp = Some n1 -> + f b1 = Some (b2, delta) -> + winject f n1 m2. + Proof. + intros. inversion H. exploit storebytes_left_mapped_winj; eauto. intros MI. constructor. + (* winj *) + auto. + (* freeblocks *) + eauto with mem. + (* mappedblocks *) + eauto with mem. + (* no overlap *) + red; intros. eauto with mem. + (* representable *) + intros. eapply mwi_representable; try eassumption. + destruct H3; eauto with mem. + (* perm inv *) + intros. exploit mwi_perm_inv; eauto using Mem.perm_storebytes_2. + intuition eauto using Mem.perm_storebytes_1, Mem.perm_storebytes_2. + Qed. + + Lemma storebytes_left_winject: + forall f m1 b1 ofs v1 cp n1 m2, + winject f m1 m2 -> + Mem.storebytes m1 b1 ofs v1 cp = Some n1 -> + winject f n1 m2. + Proof. + intros. destruct (f b1) eqn:FB. + - destruct p. eapply storebytes_left_mapped_winject; eauto. + - eapply storebytes_unmapped_winject; eauto. + Qed. + + Lemma mem_delta_apply_preserves_winject + ge cp0 m0 m0' + (WINJ0: winject (meminj_public ge) m0 m0') + (d: mem_delta) + m1 + (APPD: mem_delta_apply d (Some m0) = Some m1) + : + exists m1', (mem_delta_apply_wf ge cp0 d (Some m0') = Some m1') /\ (winject (meminj_public ge) m1 m1'). + Proof. + revert m0 m0' WINJ0 m1 APPD. induction d; intros. + { inv APPD. exists m0'. ss. } + rewrite mem_delta_apply_cons in APPD. rewrite mem_delta_apply_wf_cons. destruct a. + - exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. des_ifs. + + destruct d0 as (((ch & ptr) & v) & cp). destruct ptr; ss. destruct ((meminj_public ge) b) as [[b' ofs']|] eqn:JB. + * exploit store_mapped_winject; eauto. instantiate (1:=v). intros (mi0 & MEM' & WINJ1). specialize (IHd _ _ WINJ1 _ APPD). destruct IHd as (m1' & APPD' & WINJ'). + unfold meminj_public in JB. des_ifs. rewrite Z.add_0_r in MEM'. rewrite MEM'. eauto. + * exploit store_unmapped_winject; eauto. unfold meminj_public in JB. des_ifs. + + destruct d0 as (((ch & ptr) & v) & cp). destruct ptr; ss. exploit store_left_winject; eauto. + - destruct d0 as ((((ch & b) & ofs) & v) & cp). ss. exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. + exploit store_left_winject; eauto. + - destruct d0 as (((b & ofs) & mvs) & cp). exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. ss. exploit storebytes_left_winject; eauto. + - destruct d0 as ((cp & lo) & hi). exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. + ss. destruct (Mem.alloc m0 cp lo hi) eqn:ALLOC; simpl in *. inv MEM. exploit alloc_left_unmapped_winject_keep; eauto. + - destruct d0 as (((b & lo) & hi) & cp). exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. ss. exploit free_left_winject; eauto. + Qed. + + Lemma mem_delta_apply_keeps_perm + cp j d + (DWF: mem_delta_inj_wf cp j d) + m0 m1 + (APPD : mem_delta_apply d (Some m0) = Some m1) + b ofs + (INJ: j b <> None) + K P + (PERM: Mem.perm m1 b ofs K P) + (BOUND: (b < Mem.nextblock m0)%positive) + : + Mem.perm m0 b ofs K P. + Proof. + revert DWF m0 APPD BOUND. induction d; intros. + { simpl in *. inv APPD; auto. } + inv DWF. rename H1 into DWF1, H2 into DWF2. rewrite mem_delta_apply_cons in APPD. specialize (IHd DWF2). + destruct a; exploit mem_delta_apply_some; eauto; intros (mi & MEM); rewrite MEM in APPD; specialize (IHd _ APPD). + - destruct d0 as (((ch0 & ptr0) & v0) & cp0). ss. clarify. destruct ptr0; ss. eapply Mem.perm_store_2; eauto. eapply IHd. erewrite Mem.nextblock_store; eauto. + - destruct d0 as ((((ch0 & b0) & ofs0) & v0) & cp0). simpl in *. eapply Mem.perm_store_2; eauto. eapply IHd. erewrite Mem.nextblock_store; eauto. + - destruct d0 as (((b0 & ofs0) & mvs0) & cp0). simpl in *. eapply Mem.perm_storebytes_2; eauto. eapply IHd. erewrite Mem.nextblock_storebytes; eauto. + - destruct d0 as ((cp0 & lo0) & hi0). simpl in *. destruct (Mem.alloc m0 cp0 lo0 hi0) eqn:ALLOC. simpl in *. inv MEM. + exploit Mem.alloc_result; eauto. intros; subst b0. exploit Mem.nextblock_alloc; eauto. intros EQ. + eapply Mem.perm_alloc_4. eauto. eapply IHd. lia. lia. + - destruct d0 as (((b0 & lo0) & hi0) & cp0). simpl in *. + eapply Mem.perm_free_3; eauto. eapply IHd. erewrite Mem.nextblock_free; eauto. + Qed. + + Lemma loc_first_order_always_memval_inject + m b ofs + (FO: loc_first_order m b ofs) + j v + (VINJ: memval_inject j (ZMap.get ofs (Mem.mem_contents m) !! b) v) + : + forall k, memval_inject k (ZMap.get ofs (Mem.mem_contents m) !! b) v. + Proof. + unfold loc_first_order in FO. destruct (ZMap.get ofs (Mem.mem_contents m) !! b) eqn:MV; try contradiction. + inv VINJ. intros. constructor. + Qed. + + Lemma mem_delta_apply_establish_inject + (ge: Senv.t) (k: meminj) m0 m0' + (INJ: Mem.inject k m0 m0') + (INCR: inject_incr (meminj_public ge) k) + (NALLOC: meminj_not_alloc (meminj_public ge) m0) + (d: mem_delta) cp + (DWF: mem_delta_inj_wf cp (meminj_public ge) d) + m1 + (APPD: mem_delta_apply d (Some m0) = Some m1) + (FO: meminj_first_order (meminj_public ge) m1) + : + exists m1', (mem_delta_apply_wf ge cp d (Some m0') = Some m1') /\ (Mem.inject (meminj_public ge) m1 m1'). + Proof. + exploit inject_implies_winject; eauto. intros WINJ. exploit winject_inj_incr; eauto. clear WINJ; intro WINJ. + exploit mem_delta_apply_preserves_winject; eauto. intros (m1' & APPD' & WINJ'). exists m1'. split; eauto. + apply winject_to_inject; auto. unfold mem_inj_val. intros. + exploit mem_delta_apply_keeps_perm; eauto. congruence. + { destruct (Pos.ltb_spec0 b1 (Mem.nextblock m0)); auto. exfalso. assert ((meminj_public ge) b1 = None). + { eapply NALLOC. lia. } + congruence. + } + intros PERM0. pose proof H as INJPUB. unfold meminj_public in H. des_ifs. rename Heq into INV, Heq0 into ISPUB. + rename b2 into b1. destruct (mem_delta_unchanged_or_changed d b1 ofs). + - exploit mem_delta_unchanged_on. eapply APPD. intros UNCHG1. exploit mem_delta_wf_unchanged_on. eapply APPD'. intros UNCHG2. + erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1). erewrite (Mem.unchanged_on_contents _ _ _ UNCHG2). all: eauto. + { inv INJ. inv mi_inj. specialize (mi_memval _ _ _ _ (INCR _ _ _ INJPUB) PERM0). eapply loc_first_order_always_memval_inject; eauto. + exploit FO. erewrite INJPUB. congruence. eauto. unfold loc_first_order; intros. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1) eqn:MEMV1; try contradiction. + erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1) in MEMV1; eauto. rewrite MEMV1. auto. + } + { eapply mem_delta_unchanged_implies_wf_unchanged; eauto. rewrite Z.add_0_r. auto. } + { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. rewrite Z.add_0_r. auto. } + - rename H into CHG. exploit mem_delta_changed_only_by_storev. eauto. rewrite INJPUB; ss. eauto. eapply APPD. eapply APPD'. auto. + { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. } + { exploit FO; eauto. rewrite INJPUB. congruence. } + intros. rewrite Z.add_0_r, <- x0. + exploit FO; eauto. rewrite INJPUB; ss. intros. unfold loc_first_order in x1. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1); try contradiction. constructor. + Qed. + + Import Mem. + + Lemma mem_delta_apply_establish_inject_preprocess + (ge: Senv.t) (k: meminj) m0 m0' + (INJ: Mem.inject k m0 m0') + pch pb pofs pv pcp m0'' + (PRE: store pch m0' pb pofs pv pcp = Some m0'') + (PREB: forall b ofs, (meminj_public ge) b <> Some (pb, ofs)) + (INCR: inject_incr (meminj_public ge) k) + (NALLOC: meminj_not_alloc (meminj_public ge) m0) + (d: mem_delta) cp + (DWF: mem_delta_inj_wf cp (meminj_public ge) d) + m1 + (APPD: mem_delta_apply d (Some m0) = Some m1) + (FO: meminj_first_order (meminj_public ge) m1) + : + exists m1', (mem_delta_apply_wf ge cp d (Some m0'') = Some m1') /\ (Mem.inject (meminj_public ge) m1 m1'). + Proof. + exploit inject_implies_winject; eauto. intros WINJ. exploit winject_inj_incr; eauto. clear WINJ; intro WINJ. + hexploit store_outside_winject. eauto. + { intros. eapply PREB. rewrite H. eauto. } + eapply PRE. clear WINJ. intros WINJ. + exploit mem_delta_apply_preserves_winject. eapply WINJ. eauto. intros (m1' & APPD' & WINJ'). exists m1'. split; eauto. + apply winject_to_inject; auto. unfold mem_inj_val. intros. + exploit mem_delta_apply_keeps_perm; eauto. congruence. + { destruct (Pos.ltb_spec0 b1 (Mem.nextblock m0)); auto. exfalso. assert ((meminj_public ge) b1 = None). + { eapply NALLOC. lia. } + congruence. + } + intros PERM0. pose proof H as INJPUB. unfold meminj_public in H. des_ifs. rename Heq into INV, Heq0 into ISPUB. + rename b2 into b1. + assert (NOT_PRE: b1 <> pb). + { intros EQ. subst b1. eapply PREB. eapply INJPUB. } + destruct (mem_delta_unchanged_or_changed d b1 ofs). + - exploit mem_delta_unchanged_on. eapply APPD. intros UNCHG1. exploit mem_delta_wf_unchanged_on. eapply APPD'. intros UNCHG2. + erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1). erewrite (Mem.unchanged_on_contents _ _ _ UNCHG2). all: eauto. + { inv INJ. inv mi_inj0. specialize (mi_memval0 _ _ _ _ (INCR _ _ _ INJPUB) PERM0). eapply loc_first_order_always_memval_inject; eauto. + - exploit FO. erewrite INJPUB. congruence. eauto. unfold loc_first_order; intros. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1) eqn:MEMV1; try contradiction. + erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1) in MEMV1; eauto. rewrite MEMV1. auto. + - erewrite (store_mem_contents _ m0' _ _ _ _ m0''). 2: eapply PRE. rewrite PMap.gso. 2: auto. eauto. + } + { eapply mem_delta_unchanged_implies_wf_unchanged; eauto. rewrite Z.add_0_r. auto. } + { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. rewrite Z.add_0_r. auto. } + - rename H into CHG. exploit mem_delta_changed_only_by_storev. eauto. rewrite INJPUB; ss. eauto. eapply APPD. eapply APPD'. auto. + { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. } + { exploit FO; eauto. rewrite INJPUB. congruence. } + intros. rewrite Z.add_0_r, <- x0. + exploit FO; eauto. rewrite INJPUB; ss. intros. unfold loc_first_order in x1. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1); try contradiction. constructor. + Qed. + + Lemma mem_delta_apply_establish_inject_preprocess_gen + (ge: Senv.t) (k: meminj) m0 m0' + (INJ: Mem.inject k m0 m0') + pch pb pofs pv pcp m0'' + (PRE: store pch m0' pb pofs pv pcp = Some m0'') + (PREB: forall b ofs, (meminj_public ge) b <> Some (pb, ofs)) + (INCR: inject_incr (meminj_public ge) k) + (NALLOC: meminj_not_alloc (meminj_public ge) m0) + (d: mem_delta) cp + (DWF: mem_delta_inj_wf cp (meminj_public ge) d) + m1 + (APPD: mem_delta_apply d (Some m0) = Some m1) + : + exists m1', (mem_delta_apply_wf ge cp d (Some m0'') = Some m1') /\ + ((meminj_first_order (meminj_public ge) m1) -> Mem.inject (meminj_public ge) m1 m1'). + Proof. + exploit inject_implies_winject; eauto. intros WINJ. exploit winject_inj_incr; eauto. clear WINJ; intro WINJ. + hexploit store_outside_winject. eauto. + { intros. eapply PREB. rewrite H. eauto. } + eapply PRE. clear WINJ. intros WINJ. + exploit mem_delta_apply_preserves_winject. eapply WINJ. eauto. intros (m1' & APPD' & WINJ'). exists m1'. split; eauto. + intros FO. apply winject_to_inject; auto. unfold mem_inj_val. intros. + exploit mem_delta_apply_keeps_perm; eauto. congruence. + { destruct (Pos.ltb_spec0 b1 (Mem.nextblock m0)); auto. exfalso. assert ((meminj_public ge) b1 = None). + { eapply NALLOC. lia. } + congruence. + } + intros PERM0. pose proof H as INJPUB. unfold meminj_public in H. des_ifs. rename Heq into INV, Heq0 into ISPUB. + rename b2 into b1. + assert (NOT_PRE: b1 <> pb). + { intros EQ. subst b1. eapply PREB. eapply INJPUB. } + destruct (mem_delta_unchanged_or_changed d b1 ofs). + - exploit mem_delta_unchanged_on. eapply APPD. intros UNCHG1. exploit mem_delta_wf_unchanged_on. eapply APPD'. intros UNCHG2. + erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1). erewrite (Mem.unchanged_on_contents _ _ _ UNCHG2). all: eauto. + { inv INJ. inv mi_inj0. specialize (mi_memval0 _ _ _ _ (INCR _ _ _ INJPUB) PERM0). eapply loc_first_order_always_memval_inject; eauto. + - exploit FO. erewrite INJPUB. congruence. eauto. unfold loc_first_order; intros. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1) eqn:MEMV1; try contradiction. + erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1) in MEMV1; eauto. rewrite MEMV1. auto. + - erewrite (store_mem_contents _ m0' _ _ _ _ m0''). 2: eapply PRE. rewrite PMap.gso. 2: auto. eauto. + } + { eapply mem_delta_unchanged_implies_wf_unchanged; eauto. rewrite Z.add_0_r. auto. } + { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. rewrite Z.add_0_r. auto. } + - rename H into CHG. exploit mem_delta_changed_only_by_storev. eauto. rewrite INJPUB; ss. eauto. eapply APPD. eapply APPD'. auto. + { inv WINJ. inv mwi_inj. rewrite <- (Z.add_0_r ofs). eapply mwi_perm; eauto. } + { exploit FO; eauto. rewrite INJPUB. congruence. } + intros. rewrite Z.add_0_r, <- x0. + exploit FO; eauto. rewrite INJPUB; ss. intros. unfold loc_first_order in x1. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1); try contradiction. constructor. + Qed. + +End PROOFS. diff --git a/security/MemoryWeak.v b/security/MemoryWeak.v new file mode 100644 index 0000000000..6991b57ece --- /dev/null +++ b/security/MemoryWeak.v @@ -0,0 +1,1767 @@ +Require Import Zwf. +Require Import Axioms. +Require Import Coqlib. +Require Intv. +Require Import Maps. +Require Archi. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Split. +Require Export Memdata. +Require Export Memtype. +Require Import Memory. + +(* To avoid useless definitions of inductors in extracted code. *) +Local Unset Elimination Schemes. +Local Unset Case Analysis Schemes. + +Local Notation "a # b" := (PMap.get b a) (at level 1). + + +Section WINJ. + + Import Mem. + + (** * Generic weak injections *) + + (** A memory state [m1] generically weakly injects into another memory state [m2] via the + memory injection [f] if the following conditions hold: +- each access in [m2] that corresponds to a valid access in [m1] + is itself valid; + *) + + Record mem_winj (f: meminj) (m1 m2: mem) : Prop := + mk_mem_winj { + mwi_perm: + forall b1 b2 delta ofs k p, + f b1 = Some(b2, delta) -> + perm m1 b1 ofs k p -> + perm m2 b2 (ofs + delta) k p; + mwi_own: + forall b1 b2 delta cp, + f b1 = Some(b2, delta) -> + can_access_block m1 b1 cp -> + can_access_block m2 b2 cp; + mwi_align: + forall b1 b2 delta chunk ofs p, + f b1 = Some(b2, delta) -> + range_perm m1 b1 ofs (ofs + size_chunk chunk) Max p -> + (align_chunk chunk | delta); + }. + + (** Preservation of permissions *) + + Lemma perm_winj: + forall f m1 m2 b1 ofs k p b2 delta, + mem_winj f m1 m2 -> + perm m1 b1 ofs k p -> + f b1 = Some(b2, delta) -> + perm m2 b2 (ofs + delta) k p. + Proof. + intros. eapply mwi_perm; eauto. + Qed. + + Lemma range_perm_winj: + forall f m1 m2 b1 lo hi k p b2 delta, + mem_winj f m1 m2 -> + range_perm m1 b1 lo hi k p -> + f b1 = Some(b2, delta) -> + range_perm m2 b2 (lo + delta) (hi + delta) k p. + Proof. + intros; red; intros. + replace ofs with ((ofs - delta) + delta) by lia. + eapply perm_winj; eauto. apply H0. lia. + Qed. + + Lemma can_access_block_winj: + forall f m1 m2 b1 cp b2 delta, + mem_winj f m1 m2 -> + can_access_block m1 b1 cp -> + f b1 = Some(b2, delta) -> + can_access_block m2 b2 cp. + Proof. + intros; red. + eapply mwi_own; eauto. + Qed. + + Lemma valid_access_winj: + forall f m1 m2 b1 b2 delta chunk ofs p cp, + mem_winj f m1 m2 -> + f b1 = Some(b2, delta) -> + valid_access m1 chunk b1 ofs p cp -> + valid_access m2 chunk b2 (ofs + delta) p cp. + Proof. + intros. destruct H1 as [A [B C]]. constructor. + replace (ofs + delta + size_chunk chunk) + with ((ofs + size_chunk chunk) + delta) by lia. + eapply range_perm_winj; eauto. + split. eapply mwi_own; eauto. + apply Z.divide_add_r; auto. eapply mwi_align; eauto with mem. + Qed. + + (** Preservation of stores. *) + + Lemma setN_winj: + forall (access: Z -> Prop) delta f vl1 vl2, + list_forall2 (memval_inject f) vl1 vl2 -> + forall p c1 c2, + (forall q, access q -> memval_inject f (ZMap.get q c1) (ZMap.get (q + delta) c2)) -> + (forall q, access q -> memval_inject f (ZMap.get q (setN vl1 p c1)) + (ZMap.get (q + delta) (setN vl2 (p + delta) c2))). + Proof. + induction 1; intros; simpl. + auto. + replace (p + delta + 1) with ((p + 1) + delta) by lia. + apply IHlist_forall2; auto. + intros. rewrite ZMap.gsspec at 1. destruct (ZIndexed.eq q0 p). subst q0. + rewrite ZMap.gss. auto. + rewrite ZMap.gso. auto. unfold ZIndexed.t in *. lia. + Qed. + + Definition meminj_no_overlap (f: meminj) (m: mem) : Prop := + forall b1 b1' delta1 b2 b2' delta2 ofs1 ofs2, + b1 <> b2 -> + f b1 = Some (b1', delta1) -> + f b2 = Some (b2', delta2) -> + perm m b1 ofs1 Max Nonempty -> + perm m b2 ofs2 Max Nonempty -> + b1' <> b2' \/ ofs1 + delta1 <> ofs2 + delta2. + + Lemma store_mapped_winj: + forall f chunk m1 b1 ofs v1 cp n1 m2 b2 delta v2, + mem_winj f m1 m2 -> + store chunk m1 b1 ofs v1 cp = Some n1 -> + meminj_no_overlap f m1 -> + f b1 = Some (b2, delta) -> + exists n2, + store chunk m2 b2 (ofs + delta) v2 cp = Some n2 + /\ mem_winj f n1 n2. + Proof. + intros. + assert (valid_access m2 chunk b2 (ofs + delta) Writable (Some cp)). + eapply valid_access_winj; eauto with mem. + destruct (valid_access_store _ _ _ _ _ v2 H3) as [n2 STORE]. + exists n2; split. auto. + constructor. + (* perm *) + intros. eapply perm_store_1; [eexact STORE|]. + eapply mwi_perm; eauto. + eapply perm_store_2; eauto. + (* own *) + intros. + apply (proj1 (store_can_access_block_inj _ _ _ _ _ _ _ STORE _ _)). + eapply mwi_own; try eassumption. + apply (proj2 (store_can_access_block_inj _ _ _ _ _ _ _ H0 _ _)). + assumption. + (* align *) + intros. eapply mwi_align with (ofs := ofs0) (p := p); eauto. + red; intros; eauto with mem. + Qed. + + Lemma store_unmapped_winj: + forall f chunk m1 b1 ofs v1 cp n1 m2, + mem_winj f m1 m2 -> + store chunk m1 b1 ofs v1 cp = Some n1 -> + f b1 = None -> + mem_winj f n1 m2. + Proof. + intros. constructor. + (* perm *) + intros. eapply mwi_perm; eauto with mem. + (* own *) + intros. eapply mwi_own; eauto. + (* RB: NOTE: Should be solvable by properly extended hint databases. *) + apply (proj2 (store_can_access_block_inj _ _ _ _ _ _ _ H0 _ _)). + assumption. + (* align *) + intros. eapply mwi_align with (ofs := ofs0) (p := p); eauto. + red; intros; eauto with mem. + Qed. + + Lemma store_outside_winj: + forall f m1 m2 chunk b ofs v cp m2', + mem_winj f m1 m2 -> + (forall b' delta ofs', + f b' = Some(b, delta) -> + perm m1 b' ofs' Cur Readable -> + ofs <= ofs' + delta < ofs + size_chunk chunk -> False) -> + store chunk m2 b ofs v cp = Some m2' -> + mem_winj f m1 m2'. + Proof. + intros. inv H. constructor. + (* perm *) + eauto with mem. + (* own *) + intros. + (* RB: NOTE: Ditto re: hint databases. *) + apply (proj1 (store_can_access_block_inj _ _ _ _ _ _ _ H1 _ _)); eauto. + (* access *) + intros; eapply mwi_align0; eauto. + Qed. + + Lemma storebytes_mapped_winj: + forall f m1 b1 ofs bytes1 cp n1 m2 b2 delta bytes2, + mem_winj f m1 m2 -> + storebytes m1 b1 ofs bytes1 cp = Some n1 -> + meminj_no_overlap f m1 -> + f b1 = Some (b2, delta) -> + list_forall2 (memval_inject f) bytes1 bytes2 -> + exists n2, + storebytes m2 b2 (ofs + delta) bytes2 cp = Some n2 + /\ mem_winj f n1 n2. + Proof. + intros. inversion H. + assert (range_perm m2 b2 (ofs + delta) (ofs + delta + Z.of_nat (length bytes2)) Cur Writable). + replace (ofs + delta + Z.of_nat (length bytes2)) + with ((ofs + Z.of_nat (length bytes1)) + delta). + eapply range_perm_winj; eauto with mem. + rewrite (list_forall2_length H3). lia. + (* eapply storebytes_range_perm; eauto. *) + destruct (range_perm_storebytes _ _ _ _ cp H4) as [n2 STORE]. + eapply can_access_block_winj; try eassumption. eapply storebytes_can_access_block_1; eassumption. + exists n2; split. eauto. + constructor. + (* perm *) + intros. + eapply perm_storebytes_1; [apply STORE |]. + eapply mwi_perm0; eauto. + eapply perm_storebytes_2; eauto. + (* own *) + intros. + eapply storebytes_can_access_block_inj_1; [apply STORE |]. + eapply mwi_own0; eauto. + eapply storebytes_can_access_block_inj_2; eauto. + (* align *) + intros. eapply mwi_align with (ofs := ofs0) (p := p); eauto. + red; intros. eapply perm_storebytes_2; eauto. + Qed. + + Lemma storebytes_unmapped_winj: + forall f m1 b1 ofs bytes1 cp n1 m2, + mem_winj f m1 m2 -> + storebytes m1 b1 ofs bytes1 cp = Some n1 -> + f b1 = None -> + mem_winj f n1 m2. + Proof. + intros. inversion H. + constructor. + (* perm *) + intros. eapply mwi_perm0; eauto. eapply perm_storebytes_2; eauto. + (* own *) + intros. + eapply mwi_own0; try eassumption. + eapply storebytes_can_access_block_inj_2; eassumption. + (* align *) + intros. eapply mwi_align with (ofs := ofs0) (p := p); eauto. + red; intros. eapply perm_storebytes_2; eauto. + Qed. + + Lemma storebytes_outside_winj: + forall f m1 m2 b ofs bytes2 cp m2', + mem_winj f m1 m2 -> + (forall b' delta ofs', + f b' = Some(b, delta) -> + perm m1 b' ofs' Cur Readable -> + ofs <= ofs' + delta < ofs + Z.of_nat (length bytes2) -> False) -> + storebytes m2 b ofs bytes2 cp = Some m2' -> + mem_winj f m1 m2'. + Proof. + intros. inversion H. constructor. + (* perm *) + intros. eapply perm_storebytes_1; eauto with mem. + (* own *) + intros. eapply storebytes_can_access_block_inj_1; eauto. + (* align *) + eauto. + Qed. + + Lemma storebytes_empty_winj: + forall f m1 b1 ofs1 cp1 m1' m2 b2 ofs2 cp2 m2', + mem_winj f m1 m2 -> + storebytes m1 b1 ofs1 nil cp1 = Some m1' -> + storebytes m2 b2 ofs2 nil cp2 = Some m2' -> + mem_winj f m1' m2'. + Proof. + intros. destruct H. constructor. + (* perm *) + intros. + eapply perm_storebytes_1; eauto. + eapply mwi_perm0; eauto. + eapply perm_storebytes_2; eauto. + (* own *) + intros. + eapply storebytes_can_access_block_inj_1; eauto. + eapply mwi_own0; eauto. + eapply storebytes_can_access_block_inj_2; eauto. + (* align *) + intros. eapply mwi_align0 with (ofs := ofs) (p := p); eauto. + red; intros. eapply perm_storebytes_2; eauto. + Qed. + +(** Preservation of allocations *) + + Lemma alloc_right_winj: + forall f m1 m2 c lo hi b2 m2', + mem_winj f m1 m2 -> + alloc m2 c lo hi = (m2', b2) -> + mem_winj f m1 m2'. + Proof. + intros. injection H0. intros NEXT MEM. + inversion H. constructor. + (* perm *) + intros. eapply perm_alloc_1; eauto. + (* own *) + intros. eapply alloc_can_access_block_other_inj_1; eauto. + (* align *) + eauto. + Qed. + + Remark can_access_block_component : + forall m b cp cp', can_access_block m b (Some cp) -> can_access_block m b (Some cp') -> cp = cp'. + Proof. + congruence. + Qed. + + Lemma alloc_left_unmapped_winj: + forall f m1 m2 c lo hi m1' b1, + mem_winj f m1 m2 -> + alloc m1 c lo hi = (m1', b1) -> + f b1 = None -> + mem_winj f m1' m2. + Proof. + intros. inversion H. constructor. + (* perm *) + intros. exploit perm_alloc_inv; eauto. intros. + destruct (eq_block b0 b1). congruence. eauto. + (* own *) + intros. eapply mwi_own0; try eassumption. destruct (eq_block b0 b1). + subst b0. congruence. + eapply alloc_can_access_block_other_inj_2; eassumption. + (* align *) + intros. eapply mwi_align0 with (ofs := ofs) (p := p); eauto. + red; intros. exploit perm_alloc_inv; eauto. + destruct (eq_block b0 b1); auto. congruence. + Qed. + + Definition winj_offset_aligned (delta: Z) (size: Z) : Prop := + forall chunk, size_chunk chunk <= size -> (align_chunk chunk | delta). + + Lemma alloc_left_mapped_winj: + forall f m1 m2 c lo hi m1' b1 b2 delta, + mem_winj f m1 m2 -> + alloc m1 c lo hi = (m1', b1) -> + valid_block m2 b2 -> + winj_offset_aligned delta (hi-lo) -> + (forall ofs k p, lo <= ofs < hi -> perm m2 b2 (ofs + delta) k p) -> + f b1 = Some(b2, delta) -> + forall OWN : can_access_block m2 b2 (Some c), + mem_winj f m1' m2. + Proof. + intros. inversion H. constructor. + (* perm *) + intros. + exploit perm_alloc_inv; eauto. intros. destruct (eq_block b0 b1). subst b0. + rewrite H4 in H5; inv H5. eauto. eauto. + (* own *) + intros. destruct cp as [cp |]; [| trivial]. destruct (eq_block b0 b1). + { + subst b0. rewrite H4 in H5. inv H5. + apply owned_new_block in H0. + unfold can_access_block in *. rewrite H0 in H6. inv H6. + exact OWN. + } + { + eapply mwi_own0; eauto. eapply alloc_can_access_block_other_inj_2; eassumption. + } + (* align *) + intros. destruct (eq_block b0 b1). + subst b0. assert (delta0 = delta) by congruence. subst delta0. + assert (lo <= ofs < hi). + { eapply perm_alloc_3; eauto. apply H6. generalize (size_chunk_pos chunk); lia. } + assert (lo <= ofs + size_chunk chunk - 1 < hi). + { eapply perm_alloc_3; eauto. apply H6. generalize (size_chunk_pos chunk); lia. } + apply H2. lia. + eapply mwi_align0 with (ofs := ofs) (p := p); eauto. + red; intros. eapply perm_alloc_4; eauto. + Qed. + + Lemma free_left_winj: + forall f m1 m2 b lo hi cp m1', + mem_winj f m1 m2 -> + free m1 b lo hi cp = Some m1' -> + mem_winj f m1' m2. + Proof. + intros. exploit free_result; eauto. intro FREE. inversion H. constructor. + (* perm *) + intros. eauto with mem. + (* own *) + intros. eapply mwi_own0; eauto. eapply free_can_access_block_inj_2; eassumption. + (* align *) + intros. eapply mwi_align0 with (ofs := ofs) (p := p); eauto. + red; intros; eapply perm_free_3; eauto. + Qed. + + Lemma free_right_winj: + forall f m1 m2 b lo hi cp m2', + mem_winj f m1 m2 -> + free m2 b lo hi cp = Some m2' -> + (forall b' delta ofs k p, + f b' = Some(b, delta) -> + perm m1 b' ofs k p -> lo <= ofs + delta < hi -> False) -> + mem_winj f m1 m2'. + Proof. + intros. exploit free_result; eauto. intro FREE. inversion H. + assert (PERM: + forall b1 b2 delta ofs k p, + f b1 = Some (b2, delta) -> + perm m1 b1 ofs k p -> perm m2' b2 (ofs + delta) k p). + intros. + intros. eapply perm_free_1; eauto. + destruct (eq_block b2 b); auto. subst b. right. + assert (~ (lo <= ofs + delta < hi)). red; intros; eapply H1; eauto. + lia. + constructor. + (* perm *) + auto. + (* own *) + intros. eapply free_can_access_block_inj_1; eauto. + (* align *) + eapply mwi_align0; eauto. + Qed. + + (** Preservation of [drop_perm] operations. *) + + Lemma drop_unmapped_winj: + forall f m1 m2 b lo hi p cp m1', + mem_winj f m1 m2 -> + drop_perm m1 b lo hi p cp = Some m1' -> + f b = None -> + mem_winj f m1' m2. + Proof. + intros. inv H. constructor. + (* perm *) + intros. eapply mwi_perm0; eauto. eapply perm_drop_4; eauto. + (* own *) + intros. eapply mwi_own0; eauto. eapply can_access_block_drop_2; eauto. + (* align *) + intros. eapply mwi_align0 with (ofs := ofs) (p := p0); eauto. + red; intros; eapply perm_drop_4; eauto. + Qed. + + Lemma drop_mapped_winj: + forall f m1 m2 b1 b2 delta lo hi p cp m1', + mem_winj f m1 m2 -> + drop_perm m1 b1 lo hi p cp = Some m1' -> + meminj_no_overlap f m1 -> + (* forall DISP : meminj_no_dispute f m1, *) + f b1 = Some(b2, delta) -> + exists m2', + drop_perm m2 b2 (lo + delta) (hi + delta) p cp = Some m2' + /\ mem_winj f m1' m2'. + Proof. + intros. + assert ({ m2' | drop_perm m2 b2 (lo + delta) (hi + delta) p cp = Some m2' }). + apply range_perm_drop_2. red; intros. + replace ofs with ((ofs - delta) + delta) by lia. + eapply perm_winj; eauto. eapply range_perm_drop_1; eauto. lia. + eapply mwi_own; eauto. eapply can_access_block_drop_3; eauto. + destruct X as [m2' DROP]. exists m2'; split; auto. + inv H. + constructor. + (* perm *) + intros. + assert (perm m2 b3 (ofs + delta0) k p0). + eapply mwi_perm0; eauto. eapply perm_drop_4; eauto. + destruct (eq_block b1 b0). + (* b1 = b0 *) + subst b0. rewrite H2 in H; inv H. + destruct (zlt (ofs + delta0) (lo + delta0)). eapply perm_drop_3; eauto. + destruct (zle (hi + delta0) (ofs + delta0)). eapply perm_drop_3; eauto. + assert (perm_order p p0). + eapply perm_drop_2. eexact H0. instantiate (1 := ofs). lia. eauto. + apply perm_implies with p; auto. + eapply perm_drop_1. eauto. lia. + (* b1 <> b0 *) + eapply perm_drop_3; eauto. + destruct (eq_block b3 b2); auto. + destruct (zlt (ofs + delta0) (lo + delta)); auto. + destruct (zle (hi + delta) (ofs + delta0)); auto. + exploit H1; eauto. + instantiate (1 := ofs + delta0 - delta). + apply perm_cur_max. apply perm_implies with Freeable. + eapply range_perm_drop_1; eauto. lia. auto with mem. + eapply perm_drop_4; eauto. eapply perm_max. apply perm_implies with p0. eauto. + eauto with mem. + intuition. + (* own *) + intros. + pose proof can_access_block_drop_2 _ _ _ _ _ _ _ H0 _ _ H3 as Hown1. + pose proof can_access_block_drop_3 _ _ _ _ _ _ _ DROP as Hown2. + pose proof mwi_own0 _ _ _ _ H Hown1 as Hown3. + eapply can_access_block_drop_1; eassumption. + (* align *) + intros. eapply mwi_align0 with (ofs := ofs) (p := p0); eauto. + red; intros; eapply perm_drop_4; eauto. + Qed. + + Lemma drop_outside_winj: forall f m1 m2 b lo hi p cp m2', + mem_winj f m1 m2 -> + drop_perm m2 b lo hi p cp = Some m2' -> + (forall b' delta ofs' k p, + f b' = Some(b, delta) -> + perm m1 b' ofs' k p -> + lo <= ofs' + delta < hi -> False) -> + mem_winj f m1 m2'. + Proof. + intros. inv H. constructor. + (* perm *) + intros. eapply perm_drop_3; eauto. + destruct (eq_block b2 b); auto. subst b2. right. + destruct (zlt (ofs + delta) lo); auto. + destruct (zle hi (ofs + delta)); auto. + byContradiction. exploit H1; eauto. lia. + (* own *) + intros. eapply can_access_block_drop_1; eauto. + (* align *) + eapply mwi_align0; eauto. + Qed. + + + + (** * Memory injections *) + + (** A memory state [m1] injects into another memory state [m2] via the + memory injection [f] if the following conditions hold: +- each access in [m2] that corresponds to a valid access in [m1] + is itself valid; +- unallocated blocks in [m1] must be mapped to [None] by [f]; +- if [f b = Some(b', delta)], [b'] must be valid in [m2]; +- distinct blocks in [m1] are mapped to non-overlapping sub-blocks in [m2]; +- the sizes of [m2]'s blocks are representable with unsigned machine integers; +- pointers that could be represented using unsigned machine integers remain + representable after the injection. + *) + + Record winject' (f: meminj) (m1 m2: mem) : Prop := + mk_winject { + mwi_inj: + mem_winj f m1 m2; + mi_freeblocks: + forall b, ~(valid_block m1 b) -> f b = None; + mwi_mappedblocks: + forall b b' delta, f b = Some(b', delta) -> valid_block m2 b'; + mwi_no_overlap: + meminj_no_overlap f m1; + mwi_representable: + forall b b' delta ofs, + f b = Some(b', delta) -> + perm m1 b (Ptrofs.unsigned ofs) Max Nonempty \/ perm m1 b (Ptrofs.unsigned ofs - 1) Max Nonempty -> + delta >= 0 /\ 0 <= Ptrofs.unsigned ofs + delta <= Ptrofs.max_unsigned; + mwi_perm_inv: + forall b1 ofs b2 delta k p, + f b1 = Some(b2, delta) -> + perm m2 b2 (ofs + delta) k p -> + perm m1 b1 ofs k p \/ ~perm m1 b1 ofs Max Nonempty + }. + Definition winject := winject'. + + Local Hint Resolve mwi_mappedblocks: mem. + + (** Preservation of access validity and pointer validity *) + + Theorem valid_block_winject_1: + forall f m1 m2 b1 b2 delta, + f b1 = Some(b2, delta) -> + winject f m1 m2 -> + valid_block m1 b1. + Proof. + intros. inv H. destruct (plt b1 (nextblock m1)). auto. + assert (f b1 = None). eapply mi_freeblocks; eauto. congruence. + Qed. + + Theorem valid_block_winject_2: + forall f m1 m2 b1 b2 delta, + f b1 = Some(b2, delta) -> + winject f m1 m2 -> + valid_block m2 b2. + Proof. + intros. eapply mwi_mappedblocks; eauto. + Qed. + + Local Hint Resolve valid_block_winject_1 valid_block_winject_2: mem. + + Theorem perm_winject: + forall f m1 m2 b1 b2 delta ofs k p, + f b1 = Some(b2, delta) -> + winject f m1 m2 -> + perm m1 b1 ofs k p -> perm m2 b2 (ofs + delta) k p. + Proof. + intros. inv H0. eapply perm_winj; eauto. + Qed. + + Theorem perm_winject_inv: + forall f m1 m2 b1 ofs b2 delta k p, + winject f m1 m2 -> + f b1 = Some(b2, delta) -> + perm m2 b2 (ofs + delta) k p -> + perm m1 b1 ofs k p \/ ~perm m1 b1 ofs Max Nonempty. + Proof. + intros. eapply mwi_perm_inv; eauto. + Qed. + + Theorem range_perm_winject: + forall f m1 m2 b1 b2 delta lo hi k p, + f b1 = Some(b2, delta) -> + winject f m1 m2 -> + range_perm m1 b1 lo hi k p -> range_perm m2 b2 (lo + delta) (hi + delta) k p. + Proof. + intros. inv H0. eapply range_perm_winj; eauto. + Qed. + + Theorem valid_access_winject: + forall f m1 m2 chunk b1 ofs b2 delta p cp, + f b1 = Some(b2, delta) -> + winject f m1 m2 -> + valid_access m1 chunk b1 ofs p cp -> + valid_access m2 chunk b2 (ofs + delta) p cp. + Proof. + intros. eapply valid_access_winj; eauto. apply mwi_inj; auto. + Qed. + + Theorem valid_pointer_winject: + forall f m1 m2 b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + winject f m1 m2 -> + valid_pointer m1 b1 ofs = true -> + valid_pointer m2 b2 (ofs + delta) = true. + Proof. + intros. + pose proof valid_pointer_can_access_block _ _ _ H1 as [cp Hown]. + unfold can_access_block in Hown. + rewrite (valid_pointer_valid_access_nonpriv _ _ _ _ Hown) in H1. + rewrite valid_pointer_valid_access_nonpriv. + eapply valid_access_winject; eauto. + inv H0. inv mwi_inj0. eapply mwi_own0 with (cp := Some cp); eauto. + Qed. + + Theorem weak_valid_pointer_winject: + forall f m1 m2 b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + winject f m1 m2 -> + weak_valid_pointer m1 b1 ofs = true -> + weak_valid_pointer m2 b2 (ofs + delta) = true. + Proof. + intros until 2. unfold weak_valid_pointer. rewrite !orb_true_iff. + replace (ofs + delta - 1) with ((ofs - 1) + delta) by lia. + intros []; eauto using valid_pointer_winject. + Qed. + + (** The following lemmas establish the absence of machine integer overflow + during address computations. *) + + Lemma address_winject: + forall f m1 m2 b1 ofs1 b2 delta p, + winject f m1 m2 -> + perm m1 b1 (Ptrofs.unsigned ofs1) Cur p -> + f b1 = Some (b2, delta) -> + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta)) = Ptrofs.unsigned ofs1 + delta. + Proof. + intros. + assert (perm m1 b1 (Ptrofs.unsigned ofs1) Max Nonempty) by eauto with mem. + exploit mwi_representable; eauto. intros [A B]. + assert (0 <= delta <= Ptrofs.max_unsigned). + generalize (Ptrofs.unsigned_range ofs1). lia. + unfold Ptrofs.add. repeat rewrite Ptrofs.unsigned_repr; lia. + Qed. + + Lemma address_winject': + forall f m1 m2 chunk b1 ofs1 cp b2 delta, + winject f m1 m2 -> + valid_access m1 chunk b1 (Ptrofs.unsigned ofs1) Nonempty cp -> + f b1 = Some (b2, delta) -> + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta)) = Ptrofs.unsigned ofs1 + delta. + Proof. + intros. destruct H0. eapply address_winject; eauto. + apply H0. generalize (size_chunk_pos chunk). lia. + Qed. + + Theorem weak_valid_pointer_winject_no_overflow: + forall f m1 m2 b ofs b' delta, + winject f m1 m2 -> + weak_valid_pointer m1 b (Ptrofs.unsigned ofs) = true -> + f b = Some(b', delta) -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. + Proof. + intros. rewrite weak_valid_pointer_spec in H0. + rewrite ! valid_pointer_nonempty_perm in H0. + exploit mwi_representable; eauto. destruct H0; eauto with mem. + intros [A B]. + pose proof (Ptrofs.unsigned_range ofs). + rewrite Ptrofs.unsigned_repr; lia. + Qed. + + Theorem valid_pointer_winject_no_overflow: + forall f m1 m2 b ofs b' delta, + winject f m1 m2 -> + valid_pointer m1 b (Ptrofs.unsigned ofs) = true -> + f b = Some(b', delta) -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. + Proof. + eauto using weak_valid_pointer_winject_no_overflow, valid_pointer_implies. + Qed. + + Theorem valid_pointer_winject_val: + forall f m1 m2 b ofs b' ofs', + winject f m1 m2 -> + valid_pointer m1 b (Ptrofs.unsigned ofs) = true -> + Val.inject f (Vptr b ofs) (Vptr b' ofs') -> + valid_pointer m2 b' (Ptrofs.unsigned ofs') = true. + Proof. + intros. inv H1. + pose proof valid_pointer_can_access_block _ _ _ H0 as [cp Hown]. + erewrite address_winject'; eauto. + eapply valid_pointer_winject; eauto. + rewrite valid_pointer_valid_access_nonpriv in H0. eauto. + eauto. + Qed. + + Theorem weak_valid_pointer_winject_val: + forall f m1 m2 b ofs b' ofs', + winject f m1 m2 -> + weak_valid_pointer m1 b (Ptrofs.unsigned ofs) = true -> + Val.inject f (Vptr b ofs) (Vptr b' ofs') -> + weak_valid_pointer m2 b' (Ptrofs.unsigned ofs') = true. + Proof. + intros. inv H1. + exploit weak_valid_pointer_winject; eauto. intros W. + rewrite weak_valid_pointer_spec in H0. + rewrite ! valid_pointer_nonempty_perm in H0. + exploit mwi_representable; eauto. destruct H0; eauto with mem. + intros [A B]. + pose proof (Ptrofs.unsigned_range ofs). + unfold Ptrofs.add. repeat rewrite Ptrofs.unsigned_repr; auto; lia. + Qed. + + Theorem winject_no_overlap: + forall f m1 m2 b1 b2 b1' b2' delta1 delta2 ofs1 ofs2, + winject f m1 m2 -> + b1 <> b2 -> + f b1 = Some (b1', delta1) -> + f b2 = Some (b2', delta2) -> + perm m1 b1 ofs1 Max Nonempty -> + perm m1 b2 ofs2 Max Nonempty -> + b1' <> b2' \/ ofs1 + delta1 <> ofs2 + delta2. + Proof. + intros. inv H. eapply mwi_no_overlap0; eauto. + Qed. + + Theorem different_pointers_winject: + forall f m m' b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + winject f m m' -> + b1 <> b2 -> + valid_pointer m b1 (Ptrofs.unsigned ofs1) = true -> + valid_pointer m b2 (Ptrofs.unsigned ofs2) = true -> + f b1 = Some (b1', delta1) -> + f b2 = Some (b2', delta2) -> + b1' <> b2' \/ + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> + Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)). + Proof. + intros. + destruct (valid_pointer_can_access_block _ _ _ H1) as [cp1 Hown1]. + destruct (valid_pointer_can_access_block _ _ _ H2) as [cp2 Hown2]. + rewrite valid_pointer_valid_access_nonpriv in H1. + rewrite valid_pointer_valid_access_nonpriv in H2. + rewrite (address_winject' _ _ _ _ _ _ (Some cp1) _ _ H H1 H3). + rewrite (address_winject' _ _ _ _ _ _ (Some cp2) _ _ H H2 H4). + inv H1. simpl in H5. inv H2. simpl in H1. + eapply mwi_no_overlap; eauto. + apply perm_cur_max. apply (H5 (Ptrofs.unsigned ofs1)). lia. + apply perm_cur_max. apply (H1 (Ptrofs.unsigned ofs2)). lia. + congruence. + congruence. + Qed. + + Theorem disjoint_or_equal_winject: + forall f m m' b1 b1' delta1 b2 b2' delta2 ofs1 ofs2 sz, + winject f m m' -> + f b1 = Some(b1', delta1) -> + f b2 = Some(b2', delta2) -> + range_perm m b1 ofs1 (ofs1 + sz) Max Nonempty -> + range_perm m b2 ofs2 (ofs2 + sz) Max Nonempty -> + sz > 0 -> + b1 <> b2 \/ ofs1 = ofs2 \/ ofs1 + sz <= ofs2 \/ ofs2 + sz <= ofs1 -> + b1' <> b2' \/ ofs1 + delta1 = ofs2 + delta2 + \/ ofs1 + delta1 + sz <= ofs2 + delta2 + \/ ofs2 + delta2 + sz <= ofs1 + delta1. + Proof. + intros. + destruct (eq_block b1 b2). + assert (b1' = b2') by congruence. assert (delta1 = delta2) by congruence. subst. + destruct H5. congruence. right. destruct H5. left; congruence. right. lia. + destruct (eq_block b1' b2'); auto. subst. right. right. + set (i1 := (ofs1 + delta1, ofs1 + delta1 + sz)). + set (i2 := (ofs2 + delta2, ofs2 + delta2 + sz)). + change (snd i1 <= fst i2 \/ snd i2 <= fst i1). + apply Intv.range_disjoint'; simpl; try lia. + unfold Intv.disjoint, Intv.In; simpl; intros. red; intros. + exploit mwi_no_overlap; eauto. + instantiate (1 := x - delta1). apply H2. lia. + instantiate (1 := x - delta2). apply H3. lia. + intuition. + Qed. + + Theorem aligned_area_winject: + forall f m m' b ofs al sz b' delta cp, + winject f m m' -> + al = 1 \/ al = 2 \/ al = 4 \/ al = 8 -> sz > 0 -> + (al | sz) -> + range_perm m b ofs (ofs + sz) Cur Nonempty -> + (al | ofs) -> + f b = Some(b', delta) -> + forall OWN : can_access_block m b cp, + (al | ofs + delta). + Proof. + intros. + assert (P: al > 0) by lia. + assert (Q: Z.abs al <= Z.abs sz). apply Zdivide_bounds; auto. lia. + rewrite Z.abs_eq in Q; try lia. rewrite Z.abs_eq in Q; try lia. + assert (R: exists chunk, al = align_chunk chunk /\ al = size_chunk chunk). + destruct H0. subst; exists Mint8unsigned; auto. + destruct H0. subst; exists Mint16unsigned; auto. + destruct H0. subst; exists Mint32; auto. + subst; exists Mint64; auto. + destruct R as [chunk [A B]]. + assert (valid_access m chunk b ofs Nonempty cp). + split. red; intros; apply H3. lia. + split. assumption. congruence. + exploit valid_access_winject; eauto. intros [C [D E]]. + congruence. + Qed. + + (** Preservation of stores *) + + Theorem store_mapped_winject: + forall f chunk m1 b1 ofs v1 cp n1 m2 b2 delta v2, + winject f m1 m2 -> + store chunk m1 b1 ofs v1 cp = Some n1 -> + f b1 = Some (b2, delta) -> + exists n2, + store chunk m2 b2 (ofs + delta) v2 cp = Some n2 + /\ winject f n1 n2. + Proof. + intros. inversion H. + exploit store_mapped_winj; eauto. intros [n2 [STORE MI]]. + exists n2; split. eauto. constructor. + (* winj *) + auto. + (* freeblocks *) + eauto with mem. + (* mappedblocks *) + eauto with mem. + (* no overlap *) + red; intros. eauto with mem. + (* representable *) + intros. eapply mwi_representable; try eassumption. + destruct H3; eauto with mem. + (* perm inv *) + intros. exploit mwi_perm_inv0; eauto using perm_store_2. + intuition eauto using perm_store_1, perm_store_2. + Qed. + + Theorem store_unmapped_winject: + forall f chunk m1 b1 ofs v1 cp n1 m2, + winject f m1 m2 -> + store chunk m1 b1 ofs v1 cp = Some n1 -> + f b1 = None -> + winject f n1 m2. + Proof. + intros. inversion H. + constructor. + (* winj *) + eapply store_unmapped_winj; eauto. + (* freeblocks *) + eauto with mem. + (* mappedblocks *) + eauto with mem. + (* no overlap *) + red; intros. eauto with mem. + (* representable *) + intros. eapply mwi_representable; try eassumption. + destruct H3; eauto with mem. + (* perm inv *) + intros. exploit mwi_perm_inv0; eauto using perm_store_2. + intuition eauto using perm_store_1, perm_store_2. + Qed. + + Theorem store_outside_winject: + forall f m1 m2 chunk b ofs v cp m2', + winject f m1 m2 -> + (forall b' delta ofs', + f b' = Some(b, delta) -> + perm m1 b' ofs' Cur Readable -> + ofs <= ofs' + delta < ofs + size_chunk chunk -> False) -> + store chunk m2 b ofs v cp = Some m2' -> + winject f m1 m2'. + Proof. + intros. inversion H. constructor. + (* winj *) + eapply store_outside_winj; eauto. + (* freeblocks *) + auto. + (* mappedblocks *) + eauto with mem. + (* no overlap *) + auto. + (* representable *) + eauto with mem. + (* perm inv *) + intros. eauto using perm_store_2. + Qed. + + Theorem storev_mapped_winject: + forall f chunk m1 a1 v1 cp n1 m2 a2 v2, + winject f m1 m2 -> + storev chunk m1 a1 v1 cp = Some n1 -> + Val.inject f a1 a2 -> + Val.inject f v1 v2 -> + exists n2, + storev chunk m2 a2 v2 cp = Some n2 /\ winject f n1 n2. + Proof. + intros. inv H1; simpl in H0; try discriminate. + unfold storev. + replace (Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta))) + with (Ptrofs.unsigned ofs1 + delta). + eapply store_mapped_winject; eauto. + symmetry. eapply address_winject'; eauto with mem. + Qed. + + Theorem storebytes_mapped_winject: + forall f m1 b1 ofs bytes1 cp n1 m2 b2 delta bytes2, + winject f m1 m2 -> + storebytes m1 b1 ofs bytes1 cp = Some n1 -> + f b1 = Some (b2, delta) -> + list_forall2 (memval_inject f) bytes1 bytes2 -> + exists n2, + storebytes m2 b2 (ofs + delta) bytes2 cp = Some n2 + /\ winject f n1 n2. + Proof. + intros. inversion H. + exploit storebytes_mapped_winj; eauto. intros [n2 [STORE MI]]. + exists n2; split. eauto. constructor. + (* winj *) + auto. + (* freeblocks *) + intros. apply mi_freeblocks0. red; intros; elim H3; eapply storebytes_valid_block_1; eauto. + (* mappedblocks *) + intros. eapply storebytes_valid_block_1; eauto. + (* no overlap *) + red; intros. eapply mwi_no_overlap0; eauto; eapply perm_storebytes_2; eauto. + (* representable *) + intros. eapply mwi_representable0; eauto. + destruct H4; eauto using perm_storebytes_2. + (* perm inv *) + intros. exploit mwi_perm_inv0; eauto using perm_storebytes_2. + intuition eauto using perm_storebytes_1, perm_storebytes_2. + Qed. + + Theorem storebytes_unmapped_winject: + forall f m1 b1 ofs bytes1 cp n1 m2, + winject f m1 m2 -> + storebytes m1 b1 ofs bytes1 cp = Some n1 -> + f b1 = None -> + winject f n1 m2. + Proof. + intros. inversion H. + constructor. + (* winj *) + eapply storebytes_unmapped_winj; eauto. + (* freeblocks *) + intros. apply mi_freeblocks0. red; intros; elim H2; eapply storebytes_valid_block_1; eauto. + (* mappedblocks *) + eauto with mem. + (* no overlap *) + red; intros. eapply mwi_no_overlap0; eauto; eapply perm_storebytes_2; eauto. + (* representable *) + intros. eapply mwi_representable0; eauto. + destruct H3; eauto using perm_storebytes_2. + (* perm inv *) + intros. exploit mwi_perm_inv0; eauto. + intuition eauto using perm_storebytes_1, perm_storebytes_2. + Qed. + + Theorem storebytes_outside_winject: + forall f m1 m2 b ofs bytes2 cp m2', + winject f m1 m2 -> + (forall b' delta ofs', + f b' = Some(b, delta) -> + perm m1 b' ofs' Cur Readable -> + ofs <= ofs' + delta < ofs + Z.of_nat (length bytes2) -> False) -> + storebytes m2 b ofs bytes2 cp = Some m2' -> + winject f m1 m2'. + Proof. + intros. inversion H. constructor. + (* winj *) + eapply storebytes_outside_winj; eauto. + (* freeblocks *) + auto. + (* mappedblocks *) + intros. eapply storebytes_valid_block_1; eauto. + (* no overlap *) + auto. + (* representable *) + auto. + (* perm inv *) + intros. eapply mwi_perm_inv0; eauto using perm_storebytes_2. + Qed. + + Theorem storebytes_empty_winject: + forall f m1 b1 ofs1 cp1 m1' m2 b2 ofs2 cp2 m2', + winject f m1 m2 -> + storebytes m1 b1 ofs1 nil cp1 = Some m1' -> + storebytes m2 b2 ofs2 nil cp2 = Some m2' -> + winject f m1' m2'. + Proof. + intros. inversion H. constructor; intros. + (* winj *) + eapply storebytes_empty_winj; eauto. + (* freeblocks *) + intros. apply mi_freeblocks0. red; intros; elim H2; eapply storebytes_valid_block_1; eauto. + (* mappedblocks *) + intros. eapply storebytes_valid_block_1; eauto. + (* no overlap *) + red; intros. eapply mwi_no_overlap0; eauto; eapply perm_storebytes_2; eauto. + (* representable *) + intros. eapply mwi_representable0; eauto. + destruct H3; eauto using perm_storebytes_2. + (* perm inv *) + intros. exploit mwi_perm_inv0; eauto using perm_storebytes_2. + intuition eauto using perm_storebytes_1, perm_storebytes_2. + Qed. + + (* Preservation of allocations *) + + Theorem alloc_right_winject: + forall f m1 m2 c lo hi b2 m2', + winject f m1 m2 -> + alloc m2 c lo hi = (m2', b2) -> + winject f m1 m2'. + Proof. + intros. injection H0. intros NEXT MEM. + inversion H. constructor. + (* winj *) + eapply alloc_right_winj; eauto. + (* freeblocks *) + auto. + (* mappedblocks *) + eauto with mem. + (* no overlap *) + auto. + (* representable *) + auto. + (* perm inv *) + intros. eapply perm_alloc_inv in H2; eauto. destruct (eq_block b0 b2). + subst b0. eelim fresh_block_alloc; eauto. + eapply mwi_perm_inv0; eauto. + Qed. + + Theorem alloc_left_unmapped_winject: + forall f m1 m2 c lo hi m1' b1, + winject f m1 m2 -> + alloc m1 c lo hi = (m1', b1) -> + exists f', + winject f' m1' m2 + /\ inject_incr f f' + /\ f' b1 = None + /\ (forall b, b <> b1 -> f' b = f b). + Proof. + intros. inversion H. + set (f' := fun b => if eq_block b b1 then None else f b). + assert (inject_incr f f'). + red; unfold f'; intros. destruct (eq_block b b1). subst b. + assert (f b1 = None). eauto with mem. congruence. + auto. + assert (mem_winj f' m1 m2). + inversion mwi_inj0; constructor; eauto with mem. + unfold f'; intros. destruct (eq_block b0 b1). congruence. eauto. + unfold f'; intros. destruct (eq_block b0 b1). congruence. eauto. + unfold f'; intros. destruct (eq_block b0 b1). congruence. + unfold f'; intros. destruct (eq_block b0 b1). congruence. + eapply mwi_align0; eauto. + exists f'; split. constructor. + (* winj *) + eapply alloc_left_unmapped_winj; eauto. unfold f'; apply dec_eq_true. + (* freeblocks *) + intros. unfold f'. destruct (eq_block b b1). auto. + apply mi_freeblocks0. red; intro; elim H3. eauto with mem. + (* mappedblocks *) + unfold f'; intros. destruct (eq_block b b1). congruence. eauto. + (* no overlap *) + unfold f'; red; intros. + destruct (eq_block b0 b1); destruct (eq_block b2 b1); try congruence. + eapply mwi_no_overlap0. eexact H3. eauto. eauto. + exploit perm_alloc_inv. eauto. eexact H6. rewrite dec_eq_false; auto. + exploit perm_alloc_inv. eauto. eexact H7. rewrite dec_eq_false; auto. + (* representable *) + unfold f'; intros. + destruct (eq_block b b1); try discriminate. + eapply mwi_representable0; try eassumption. + destruct H4; eauto using perm_alloc_4. + (* perm inv *) + intros. unfold f' in H3; destruct (eq_block b0 b1); try discriminate. + exploit mwi_perm_inv0; eauto. + intuition eauto using perm_alloc_1, perm_alloc_4. + (* incr *) + split. auto. + (* image *) + split. unfold f'; apply dec_eq_true. + (* incr *) + intros; unfold f'; apply dec_eq_false; auto. + Qed. + + Theorem alloc_left_mapped_winject: + forall f m1 m2 c lo hi m1' b1 b2 delta, + winject f m1 m2 -> + alloc m1 c lo hi = (m1', b1) -> + valid_block m2 b2 -> + forall OWN : can_access_block m2 b2 (Some c), + 0 <= delta <= Ptrofs.max_unsigned -> + (forall ofs k p, perm m2 b2 ofs k p -> delta = 0 \/ 0 <= ofs < Ptrofs.max_unsigned) -> + (forall ofs k p, lo <= ofs < hi -> perm m2 b2 (ofs + delta) k p) -> + winj_offset_aligned delta (hi-lo) -> + (forall b delta' ofs k p, + f b = Some (b2, delta') -> + perm m1 b ofs k p -> + lo + delta <= ofs + delta' < hi + delta -> False) -> + exists f', + winject f' m1' m2 + /\ inject_incr f f' + /\ f' b1 = Some(b2, delta) + /\ (forall b, b <> b1 -> f' b = f b). + Proof. + intros. inversion H. + set (f' := fun b => if eq_block b b1 then Some(b2, delta) else f b). + assert (inject_incr f f'). + red; unfold f'; intros. destruct (eq_block b b1). subst b. + assert (f b1 = None). eauto with mem. congruence. + auto. + assert (mem_winj f' m1 m2). + inversion mwi_inj0; constructor; eauto with mem. + unfold f'; intros. destruct (eq_block b0 b1). + inversion H8. subst b0 b3 delta0. + elim (fresh_block_alloc _ _ _ _ _ _ H0). eauto with mem. + eauto. + unfold f'; intros. destruct cp as [cp |]; [| trivial]. destruct (eq_block b0 b1). + inversion H8. subst b0 b3 delta0. + apply unowned_fresh_block with (c' := cp) in H0. contradiction. + eapply mwi_own0; eauto. + unfold f'; intros. destruct (eq_block b0 b1). + inversion H8. subst b0 b3 delta0. + elim (fresh_block_alloc _ _ _ _ _ _ H0). + eapply perm_valid_block with (ofs := ofs). apply H9. generalize (size_chunk_pos chunk); lia. + eauto. + exists f'. split. constructor. + (* winj *) + eapply alloc_left_mapped_winj; eauto. unfold f'; apply dec_eq_true. + (* freeblocks *) + unfold f'; intros. destruct (eq_block b b1). subst b. + elim H9. eauto with mem. + eauto with mem. + (* mappedblocks *) + unfold f'; intros. destruct (eq_block b b1). congruence. eauto. + (* overlap *) + unfold f'; red; intros. + exploit perm_alloc_inv. eauto. eexact H12. intros P1. + exploit perm_alloc_inv. eauto. eexact H13. intros P2. + destruct (eq_block b0 b1); destruct (eq_block b3 b1). + congruence. + inversion H10; subst b0 b1' delta1. + destruct (eq_block b2 b2'); auto. subst b2'. right; red; intros. + eapply H6; eauto. lia. + inversion H11; subst b3 b2' delta2. + destruct (eq_block b1' b2); auto. subst b1'. right; red; intros. + eapply H6; eauto. lia. + eauto. + (* representable *) + unfold f'; intros. + destruct (eq_block b b1). + subst. injection H9; intros; subst b' delta0. destruct H10. + exploit perm_alloc_inv; eauto; rewrite dec_eq_true; intro. + exploit H3. apply H4 with (k := Max) (p := Nonempty); eauto. + generalize (Ptrofs.unsigned_range_2 ofs). lia. + exploit perm_alloc_inv; eauto; rewrite dec_eq_true; intro. + exploit H3. apply H4 with (k := Max) (p := Nonempty); eauto. + generalize (Ptrofs.unsigned_range_2 ofs). lia. + eapply mwi_representable0; try eassumption. + destruct H10; eauto using perm_alloc_4. + (* perm inv *) + intros. unfold f' in H9; destruct (eq_block b0 b1). + inversion H9; clear H9; subst b0 b3 delta0. + assert (EITHER: lo <= ofs < hi \/ ~(lo <= ofs < hi)) by lia. + destruct EITHER. + left. apply perm_implies with Freeable; auto with mem. eapply perm_alloc_2; eauto. + right; intros A. eapply perm_alloc_inv in A; eauto. rewrite dec_eq_true in A. tauto. + exploit mwi_perm_inv0; eauto. intuition eauto using perm_alloc_1, perm_alloc_4. + (* incr *) + split. auto. + (* image of b1 *) + split. unfold f'; apply dec_eq_true. + (* image of others *) + intros. unfold f'; apply dec_eq_false; auto. + Qed. + + Theorem alloc_parallel_winject: + forall f m1 m2 c lo1 hi1 m1' b1 lo2 hi2, + winject f m1 m2 -> + alloc m1 c lo1 hi1 = (m1', b1) -> + lo2 <= lo1 -> hi1 <= hi2 -> + exists f', exists m2', exists b2, + alloc m2 c lo2 hi2 = (m2', b2) + /\ winject f' m1' m2' + /\ inject_incr f f' + /\ f' b1 = Some(b2, 0) + /\ (forall b, b <> b1 -> f' b = f b). + Proof. + intros. + case_eq (alloc m2 c lo2 hi2). intros m2' b2 ALLOC. + exploit alloc_left_mapped_winject. + eapply alloc_right_winject; eauto. + eauto. + instantiate (1 := b2). eauto with mem. + eapply owned_new_block; eauto. + instantiate (1 := 0). unfold Ptrofs.max_unsigned. generalize Ptrofs.modulus_pos; lia. + auto. + intros. apply perm_implies with Freeable; auto with mem. + eapply perm_alloc_2; eauto. lia. + red; intros. apply Z.divide_0_r. + intros. apply (valid_not_valid_diff m2 b2 b2); eauto with mem. + intros [f' [A [B [C D]]]]. + exists f'; exists m2'; exists b2; auto. + Qed. + + (** Preservation of [free] operations *) + + Lemma free_left_winject: + forall f m1 m2 b lo hi cp m1', + winject f m1 m2 -> + free m1 b lo hi cp = Some m1' -> + winject f m1' m2. + Proof. + intros. inversion H. constructor. + (* winj *) + eapply free_left_winj; eauto. + (* freeblocks *) + eauto with mem. + (* mappedblocks *) + auto. + (* no overlap *) + red; intros. eauto with mem. + (* representable *) + intros. eapply mwi_representable0; try eassumption. + destruct H2; eauto with mem. + (* perm inv *) + intros. exploit mwi_perm_inv0; eauto. intuition eauto using perm_free_3. + eapply perm_free_inv in H4; eauto. destruct H4 as [[A B] | A]; auto. + subst b1. right; eapply perm_free_2; eauto. + Qed. + + Lemma free_list_left_winject: + forall f m2 l cp m1 m1', + winject f m1 m2 -> + free_list m1 l cp = Some m1' -> + winject f m1' m2. + Proof. + induction l; simpl; intros. + inv H0. auto. + destruct a as [[b lo] hi]. + destruct (free m1 b lo hi) as [m11|] eqn:E; try discriminate. + apply IHl with cp m11; auto. eapply free_left_winject; eauto. + Qed. + + Lemma free_right_winject: + forall f m1 m2 b lo hi cp m2', + winject f m1 m2 -> + free m2 b lo hi cp = Some m2' -> + (forall b1 delta ofs k p, + f b1 = Some(b, delta) -> perm m1 b1 ofs k p -> + lo <= ofs + delta < hi -> False) -> + winject f m1 m2'. + Proof. + intros. inversion H. constructor. + (* winj *) + eapply free_right_winj; eauto. + (* freeblocks *) + auto. + (* mappedblocks *) + eauto with mem. + (* no overlap *) + auto. + (* representable *) + auto. + (* perm inv *) + intros. eauto using perm_free_3. + Qed. + + Lemma perm_free_list: + forall l m cp m' b ofs k p, + free_list m l cp = Some m' -> + perm m' b ofs k p -> + perm m b ofs k p /\ + (forall lo hi, In (b, lo, hi) l -> lo <= ofs < hi -> False). + Proof. + induction l; simpl; intros. + inv H. auto. + destruct a as [[b1 lo1] hi1]. + destruct (free m b1 lo1 hi1) as [m1|] eqn:E; try discriminate. + exploit IHl; eauto. intros [A B]. + split. eauto with mem. + intros. destruct H1. inv H1. + elim (perm_free_2 _ _ _ _ _ _ E ofs k p). auto. auto. + eauto. + Qed. + + Theorem free_winject: + forall f m1 l cp1 m1' m2 b lo hi cp2 m2', + winject f m1 m2 -> + free_list m1 l cp1 = Some m1' -> + free m2 b lo hi cp2 = Some m2' -> + (forall b1 delta ofs k p, + f b1 = Some(b, delta) -> + perm m1 b1 ofs k p -> lo <= ofs + delta < hi -> + exists lo1, exists hi1, In (b1, lo1, hi1) l /\ lo1 <= ofs < hi1) -> + winject f m1' m2'. + Proof. + intros. + eapply free_right_winject; eauto. + eapply free_list_left_winject; eauto. + intros. exploit perm_free_list; eauto. intros [A B]. + exploit H2; eauto. intros [lo1 [hi1 [C D]]]. eauto. + Qed. + + Theorem free_parallel_winject: + forall f m1 m2 b lo hi cp m1' b' delta, + winject f m1 m2 -> + free m1 b lo hi cp = Some m1' -> + f b = Some(b', delta) -> + exists m2', + free m2 b' (lo + delta) (hi + delta) cp = Some m2' + /\ winject f m1' m2'. + Proof. + intros. + destruct (range_perm_free m2 b' (lo + delta) (hi + delta) cp) as [m2' FREE]. + eapply range_perm_winject; eauto. eapply free_range_perm; eauto. + inv H. inv mwi_inj0. eapply mwi_own0; eauto. eapply free_can_access_block_1; eauto. + exists m2'; split; auto. + eapply free_winject with (m1 := m1) (l := (b,lo,hi)::nil); eauto. + simpl; rewrite H0; auto. + intros. destruct (eq_block b1 b). + subst b1. rewrite H1 in H2; inv H2. + exists lo, hi; split; auto with coqlib. lia. + exploit mwi_no_overlap. eexact H. eexact n. eauto. eauto. + eapply perm_max. eapply perm_implies. eauto. auto with mem. + instantiate (1 := ofs + delta0 - delta). + apply perm_cur_max. apply perm_implies with Freeable; auto with mem. + eapply free_range_perm; eauto. lia. + intros [A|A]. congruence. lia. + Qed. + + Lemma drop_outside_winject: forall f m1 m2 b lo hi p cp m2', + winject f m1 m2 -> + drop_perm m2 b lo hi p cp = Some m2' -> + (forall b' delta ofs k p, + f b' = Some(b, delta) -> + perm m1 b' ofs k p -> lo <= ofs + delta < hi -> False) -> + winject f m1 m2'. + Proof. + intros. destruct H. constructor; eauto. + eapply drop_outside_winj; eauto. + intros. unfold valid_block in *. erewrite nextblock_drop; eauto. + intros. eapply mwi_perm_inv0; eauto using perm_drop_4. + Qed. + + (** Composing two memory winjections. *) + + Lemma mem_winj_compose: + forall f f' m1 m2 m3, + mem_winj f m1 m2 -> mem_winj f' m2 m3 -> mem_winj (compose_meminj f f') m1 m3. + Proof. + intros. unfold compose_meminj. inv H; inv H0; constructor; intros. + (* perm *) + destruct (f b1) as [[b' delta'] |] eqn:?; try discriminate. + destruct (f' b') as [[b'' delta''] |] eqn:?; inv H. + replace (ofs + (delta' + delta'')) with ((ofs + delta') + delta'') by lia. + eauto. + (* own *) + destruct (f b1) as [[b' delta'] |] eqn:?; try discriminate. + destruct (f' b') as [[b'' delta''] |] eqn:?; inv H. + eapply mwi_own1; eauto. + (* align *) + destruct (f b1) as [[b' delta'] |] eqn:?; try discriminate. + destruct (f' b') as [[b'' delta''] |] eqn:?; inv H. + apply Z.divide_add_r. + eapply mwi_align0; eauto. + eapply mwi_align1 with (ofs := ofs + delta') (p := p); eauto. + red; intros. replace ofs0 with ((ofs0 - delta') + delta') by lia. + eapply mwi_perm0; eauto. apply H0. lia. + Qed. + + Theorem winject_compose: + forall f f' m1 m2 m3, + winject f m1 m2 -> winject f' m2 m3 -> + winject (compose_meminj f f') m1 m3. + Proof. + unfold compose_meminj; intros. + inv H; inv H0. constructor. + (* winj *) + eapply mem_winj_compose; eauto. + (* unmapped *) + intros. erewrite mi_freeblocks0; eauto. + (* mapped *) + intros. + destruct (f b) as [[b1 delta1] |] eqn:?; try discriminate. + destruct (f' b1) as [[b2 delta2] |] eqn:?; inv H. + eauto. + (* no overlap *) + red; intros. + destruct (f b1) as [[b1x delta1x] |] eqn:?; try discriminate. + destruct (f' b1x) as [[b1y delta1y] |] eqn:?; inv H0. + destruct (f b2) as [[b2x delta2x] |] eqn:?; try discriminate. + destruct (f' b2x) as [[b2y delta2y] |] eqn:?; inv H1. + exploit mwi_no_overlap0; eauto. intros A. + destruct (eq_block b1x b2x). + subst b1x. destruct A. congruence. + assert (delta1y = delta2y) by congruence. right; lia. + exploit mwi_no_overlap1. eauto. eauto. eauto. + eapply perm_winj. eauto. eexact H2. eauto. + eapply perm_winj. eauto. eexact H3. eauto. + intuition lia. + (* representable *) + intros. + destruct (f b) as [[b1 delta1] |] eqn:?; try discriminate. + destruct (f' b1) as [[b2 delta2] |] eqn:?; inv H. + exploit mwi_representable0; eauto. intros [A B]. + set (ofs' := Ptrofs.repr (Ptrofs.unsigned ofs + delta1)). + assert (Ptrofs.unsigned ofs' = Ptrofs.unsigned ofs + delta1). + unfold ofs'; apply Ptrofs.unsigned_repr. auto. + exploit mwi_representable1. eauto. instantiate (1 := ofs'). + rewrite H. + replace (Ptrofs.unsigned ofs + delta1 - 1) with + ((Ptrofs.unsigned ofs - 1) + delta1) by lia. + destruct H0; eauto using perm_winj. + rewrite H. lia. + (* perm inv *) + intros. + destruct (f b1) as [[b' delta'] |] eqn:?; try discriminate. + destruct (f' b') as [[b'' delta''] |] eqn:?; try discriminate. + inversion H; clear H; subst b'' delta. + replace (ofs + (delta' + delta'')) with ((ofs + delta') + delta'') in H0 by lia. + exploit mwi_perm_inv1; eauto. intros [A|A]. + eapply mwi_perm_inv0; eauto. + right; red; intros. elim A. eapply perm_winj; eauto. + Qed. + + + (** Winjecting a memory into itself. *) + + Definition flat_winj (thr: block) : meminj := + fun (b: block) => if plt b thr then Some(b, 0) else None. + + Definition winject_neutral (thr: block) (m: mem) := + mem_winj (flat_winj thr) m m. + + Remark flat_winj_no_overlap: + forall thr m, meminj_no_overlap (flat_winj thr) m. + Proof. + unfold flat_winj; intros; red; intros. + destruct (plt b1 thr); inversion H0; subst. + destruct (plt b2 thr); inversion H1; subst. + auto. + Qed. + + Theorem neutral_winject: + forall m, winject_neutral (nextblock m) m -> winject (flat_winj (nextblock m)) m m. + Proof. + intros. constructor. + (* meminj *) + auto. + (* freeblocks *) + unfold flat_winj, valid_block; intros. + apply pred_dec_false. auto. + (* mappedblocks *) + unfold flat_winj, valid_block; intros. + destruct (plt b (nextblock m)); inversion H0; subst. auto. + (* no overlap *) + apply flat_winj_no_overlap. + (* range *) + unfold flat_winj; intros. + destruct (plt b (nextblock m)); inv H0. generalize (Ptrofs.unsigned_range_2 ofs); lia. + (* perm inv *) + unfold flat_winj; intros. + destruct (plt b1 (nextblock m)); inv H0. + rewrite Z.add_0_r in H1; auto. + Qed. + + Theorem empty_winject_neutral: + forall thr, winject_neutral thr empty. + Proof. + intros; red; constructor. + (* perm *) + unfold flat_winj; intros. destruct (plt b1 thr); inv H. + replace (ofs + 0) with ofs by lia; auto. + (* own *) + intros. destruct cp as [cp| ]; [| trivial]. + unfold can_access_block, block_compartment in H0. + now rewrite PTree.gempty in H0. + (* align *) + unfold flat_winj; intros. destruct (plt b1 thr); inv H. apply Z.divide_0_r. + Qed. + + Theorem alloc_winject_neutral: + forall thr m c lo hi b m', + alloc m c lo hi = (m', b) -> + winject_neutral thr m -> + Plt (nextblock m) thr -> + winject_neutral thr m'. + Proof. + intros; red. + eapply alloc_left_mapped_winj with (m1 := m) (b2 := b) (delta := 0). + eapply alloc_right_winj; eauto. eauto. eauto with mem. + red. intros. apply Z.divide_0_r. + intros. + apply perm_implies with Freeable; auto with mem. + eapply perm_alloc_2; eauto. lia. + unfold flat_winj. apply pred_dec_true. + rewrite (alloc_result _ _ _ _ _ _ H). auto. + eapply owned_new_block; eauto. + Qed. + + Theorem drop_winject_neutral: + forall m b lo hi p cp m' thr, + drop_perm m b lo hi p cp = Some m' -> + winject_neutral thr m -> + Plt b thr -> + winject_neutral thr m'. + Proof. + unfold winject_neutral; intros. + exploit drop_mapped_winj; eauto. apply flat_winj_no_overlap. + unfold flat_winj. apply pred_dec_true; eauto. + repeat rewrite Z.add_0_r. intros [m'' [A B]]. congruence. + Qed. + +End WINJ. + +Section PROPS. + + Lemma mem_winj_inj_incr + j1 j2 m m' + (INCR: inject_incr j1 j2) + (WINJ: mem_winj j2 m m') + : + mem_winj j1 m m'. + Proof. inv WINJ. split; eauto. Qed. + + Lemma winject_inj_incr + j1 j2 m m' + (INCR: inject_incr j1 j2) + (WINJ: winject j2 m m') + : + winject j1 m m'. + Proof. + inv WINJ. split; eauto. eapply mem_winj_inj_incr; eauto. + { intros. destruct (j1 b) as [[b' ofs']|] eqn: JB; auto. specialize (INCR _ _ _ JB). specialize (mi_freeblocks0 _ H). rewrite INCR in mi_freeblocks0. congruence. } + { unfold meminj_no_overlap in *. intros. eapply mwi_no_overlap0; eauto. } + Qed. + + Lemma mem_inj_implies_mem_winj + j m m' + (INJ: Mem.mem_inj j m m') + : + mem_winj j m m'. + Proof. inv INJ. split; auto. Qed. + + Lemma inject_implies_winject + j m m' + (INJ: Mem.inject j m m') + : + winject j m m'. + Proof. inv INJ. split; auto. apply mem_inj_implies_mem_winj; auto. Qed. + + Definition mem_inj_val f m1 m2 := + forall (b1 : block) (ofs : Z) (b2 : block) (delta : Z), + f b1 = Some (b2, delta) -> Mem.perm m1 b1 ofs Cur Readable -> memval_inject f (ZMap.get ofs (Mem.mem_contents m1) # b1) (ZMap.get (ofs + delta) (Mem.mem_contents m2) # b2). + + Lemma mem_winj_to_mem_inj + j m m' + (WINJ: mem_winj j m m') + (INJV: mem_inj_val j m m') + : + Mem.mem_inj j m m'. + Proof. inv WINJ. split; eauto. Qed. + + Lemma winject_to_inject + j m m' + (WINJ: winject j m m') + (INJV: mem_inj_val j m m') + : + Mem.inject j m m'. + Proof. inv WINJ. split; eauto. apply mem_winj_to_mem_inj; auto. Qed. + +End PROPS. + + +(** * Weak Invariance properties between two memory states *) + +Section WUNCHANGED_ON. + +Import Mem. + +Variable P: block -> Z -> Prop. + +Record wunchanged_on (m_before m_after: mem) : Prop := mk_wunchanged_on { + wunchanged_on_nextblock: + Ple (nextblock m_before) (nextblock m_after); + wunchanged_on_perm: + forall b ofs k p, + P b ofs -> valid_block m_before b -> + (perm m_before b ofs k p <-> perm m_after b ofs k p); + wunchanged_on_own: + forall b cp, + (* P b ofs -> *) + valid_block m_before b -> (* Adjust preconditions as needed. *) + (can_access_block m_before b cp <-> can_access_block m_after b cp) +}. + +Lemma wunchanged_on_refl: + forall m, wunchanged_on m m. +Proof. + intros; constructor. apply Ple_refl. tauto. tauto. +Qed. + +Lemma valid_block_wunchanged_on: + forall m m' b, + wunchanged_on m m' -> valid_block m b -> valid_block m' b. +Proof. + unfold valid_block; intros. apply wunchanged_on_nextblock in H. extlia. +Qed. + +Lemma perm_wunchanged_on: + forall m m' b ofs k p, + wunchanged_on m m' -> P b ofs -> + perm m b ofs k p -> perm m' b ofs k p. +Proof. + intros. destruct H. apply wunchanged_on_perm0; auto. eapply perm_valid_block; eauto. +Qed. + +Lemma perm_wunchanged_on_2: + forall m m' b ofs k p, + wunchanged_on m m' -> P b ofs -> valid_block m b -> + perm m' b ofs k p -> perm m b ofs k p. +Proof. + intros. destruct H. apply wunchanged_on_perm0; auto. +Qed. + +Lemma wunchanged_on_trans: + forall m1 m2 m3, wunchanged_on m1 m2 -> wunchanged_on m2 m3 -> wunchanged_on m1 m3. +Proof. + intros; constructor. +- apply Ple_trans with (nextblock m2); apply wunchanged_on_nextblock; auto. +- intros. transitivity (perm m2 b ofs k p); apply wunchanged_on_perm; auto. + eapply valid_block_wunchanged_on; eauto. +- intros. transitivity (can_access_block m2 b cp); apply wunchanged_on_own; auto. + eapply valid_block_wunchanged_on; eauto. +Qed. + +Lemma store_wunchanged_on: + forall chunk m b ofs v cp m', + store chunk m b ofs v cp = Some m' -> + wunchanged_on m m'. +Proof. + intros; constructor; intros. +- rewrite (nextblock_store _ _ _ _ _ _ _ H). apply Ple_refl. +- split; intros; eauto with mem. +- eapply store_can_access_block_inj; eauto. +Qed. + +Lemma storebytes_wunchanged_on: + forall m b ofs bytes cp m', + storebytes m b ofs bytes cp = Some m' -> + wunchanged_on m m'. +Proof. + intros; constructor; intros. +- rewrite (nextblock_storebytes _ _ _ _ _ _ H). apply Ple_refl. +- split; intros. eapply perm_storebytes_1; eauto. eapply perm_storebytes_2; eauto. +- split. + eapply storebytes_can_access_block_inj_1; eauto. + eapply storebytes_can_access_block_inj_2; eauto. +Qed. + +Lemma alloc_wunchanged_on: + forall m c lo hi m' b, + alloc m c lo hi = (m', b) -> + wunchanged_on m m'. +Proof. + intros; constructor; intros. +- rewrite (nextblock_alloc _ _ _ _ _ _ H). apply Ple_succ. +- split; intros. + eapply perm_alloc_1; eauto. + eapply perm_alloc_4; eauto. + eapply valid_not_valid_diff; eauto with mem. +- destruct (peq b0 b). ++ subst b0. apply fresh_block_alloc in H. contradiction. ++ split. + eapply alloc_can_access_block_other_inj_1; eauto. + eapply alloc_can_access_block_other_inj_2; eauto. +Qed. + +Lemma free_wunchanged_on: + forall m b lo hi cp m', + free m b lo hi cp = Some m' -> + (forall i, lo <= i < hi -> ~ P b i) -> + wunchanged_on m m'. +Proof. + intros; constructor; intros. +- rewrite (nextblock_free _ _ _ _ _ _ H). apply Ple_refl. +- split; intros. + eapply perm_free_1; eauto. + destruct (eq_block b0 b); auto. destruct (zlt ofs lo); auto. destruct (zle hi ofs); auto. + subst b0. elim (H0 ofs). lia. auto. + eapply perm_free_3; eauto. +- split. + eapply free_can_access_block_inj_1; eauto. + eapply free_can_access_block_inj_2; eauto. +Qed. + +Lemma drop_perm_wunchanged_on: + forall m b lo hi p cp m', + drop_perm m b lo hi p cp = Some m' -> + (forall i, lo <= i < hi -> ~ P b i) -> + wunchanged_on m m'. +Proof. + intros; constructor; intros. +- rewrite (nextblock_drop _ _ _ _ _ _ _ H). apply Ple_refl. +- split; intros. eapply perm_drop_3; eauto. + destruct (eq_block b0 b); auto. + subst b0. + assert (~ (lo <= ofs < hi)). { red; intros; eelim H0; eauto. } + right; lia. + eapply perm_drop_4; eauto. +- split. + eapply can_access_block_drop_1; eauto. + eapply can_access_block_drop_2; eauto. +Qed. + +End WUNCHANGED_ON. + +Lemma wunchanged_on_implies: + forall (P Q: block -> Z -> Prop) m m', + wunchanged_on P m m' -> + (forall b ofs, Q b ofs -> Mem.valid_block m b -> P b ofs) -> + wunchanged_on Q m m'. +Proof. + intros. destruct H. constructor; intros. +- auto. +- apply wunchanged_on_perm0; auto. +- apply wunchanged_on_own0; auto. +Qed. diff --git a/security/Tactics.v b/security/Tactics.v new file mode 100644 index 0000000000..bd110a077a --- /dev/null +++ b/security/Tactics.v @@ -0,0 +1,959 @@ +(* *********************************************************************) +(* *) +(* Lemmas & Tactic from coq-sflib: *) +(* https://github.com/snu-sf/sflib/blob/master/sflib.v *) +(* *) +(* *********************************************************************) + +(* *********************************************************************) +(* *) +(* Software Foundations Laboratory's Lemmas & Tactic *) +(* based on Viktor and Gil's lemmas & tactic *) +(* *) +(* *********************************************************************) + +(** This file collects a number of basic lemmas and tactics for better + proof automation, structuring large proofs, or rewriting. Most of + the rewriting support is ported from ssreflect. *) + +(** Symbols starting with [sflib__] are internal. *) + +Require Import Bool List Arith ZArith String Program. +(* Require Export paconotation newtac. *) + +Set Implicit Arguments. + +#[export] Hint Unfold not iff id: core. + +Export ListNotations. + +(* Notation "~ x" := (forall (FH: x), False) : type_scope. *) + +(* Function composition *) +Notation "f <*> g" := (compose f g) (at level 49, left associativity). + +(* ************************************************************************** *) +(** * Coersion of [bool] into [Prop] *) +(* ************************************************************************** *) + +(** Coersion of bools into Prop *) +Coercion is_true (b : bool) : Prop := b = true. + +(** Hints for auto *) +Lemma sflib__true_is_true : true. +Proof. reflexivity. Qed. + +Lemma sflib__not_false_is_true : ~ false. +Proof. discriminate. Qed. + +Lemma sflib__negb_rewrite: forall {b}, negb b -> b = false. +Proof. intros []; (reflexivity || discriminate). Qed. + +Lemma sflib__andb_split: forall {b1 b2}, b1 && b2 -> b1 /\ b2. +Proof. intros [] []; try discriminate; auto. Qed. + +#[export] Hint Resolve sflib__true_is_true sflib__not_false_is_true: core. + +(* ************************************************************************** *) +(** * Basic automation tactics *) +(* ************************************************************************** *) + +(** Set up for basic simplification *) + +Create HintDb sflib discriminated. + +(** Adaptation of the ss-reflect "[done]" tactic. *) + +Ltac sflib__basic_done := + solve [trivial with sflib | apply sym_equal; trivial | discriminate | contradiction]. + +Ltac done := unfold not in *; trivial with sflib; hnf; intros; + solve [try sflib__basic_done; split; + try sflib__basic_done; split; + try sflib__basic_done; split; + try sflib__basic_done; split; + try sflib__basic_done; split; sflib__basic_done + | match goal with H : _ -> False |- _ => solve [case H; trivial] end]. + +(** A variant of the ssr "done" tactic that performs "eassumption". *) + +Ltac edone := try eassumption; trivial; hnf; intros; + solve [try eassumption; try sflib__basic_done; split; + try eassumption; try sflib__basic_done; split; + try eassumption; try sflib__basic_done; split; + try eassumption; try sflib__basic_done; split; + try eassumption; try sflib__basic_done; split; + try eassumption; sflib__basic_done + | match goal with H : ~ _ |- _ => solve [case H; trivial] end]. + +Tactic Notation "by" tactic(tac) := (tac; done). +Tactic Notation "eby" tactic(tac) := (tac; edone). + +Ltac sflib__complaining_inj f H := + let X := fresh in + (match goal with | [|- ?P ] => set (X := P) end); + injection H; + (lazymatch goal with | [ |- f _ = f _ -> _] => fail | _ => idtac end); + clear H; intros; + subst X; + try subst. + +Ltac sflib__clarify1 := + try subst; + repeat match goal with + | [H: is_true (andb _ _) |- _] => case (sflib__andb_split H); clear H; intros ? H + | [H: is_true (negb ?x) |- _] => rewrite (sflib__negb_rewrite H) in * + | [H: is_true ?x |- _] => rewrite H in * + | [H: ?x = true |- _] => rewrite H in * + | [H: ?x = false |- _] => rewrite H in * + | [H: ?f _ = ?f _ |- _] => sflib__complaining_inj f H + | [H: ?f _ _ = ?f _ _ |- _] => sflib__complaining_inj f H + | [H: ?f _ _ _ = ?f _ _ _ |- _] => sflib__complaining_inj f H + | [H: ?f _ _ _ _ = ?f _ _ _ _ |- _] => sflib__complaining_inj f H + | [H: ?f _ _ _ _ _ = ?f _ _ _ _ _ |- _] => sflib__complaining_inj f H + | [H: ?f _ _ _ _ _ _ = ?f _ _ _ _ _ _ |- _] => sflib__complaining_inj f H + | [H: ?f _ _ _ _ _ _ _ = ?f _ _ _ _ _ _ _ |- _] => sflib__complaining_inj f H + end; try done. + +(** Perform injections & discriminations on all hypotheses *) + +Ltac clarify := + sflib__clarify1; + repeat match goal with + | H1: ?x = Some _, H2: ?x = None |- _ => rewrite H2 in H1; sflib__clarify1 + | H1: ?x = Some _, H2: ?x = Some _ |- _ => rewrite H2 in H1; sflib__clarify1 + end. + +(** Kill simple goals that require up to two econstructor calls. *) + +(* from CompCert-2.4/lib/Coqlib.v *) +Ltac inv H := inversion H; clear H; subst. + +Ltac hinv x := move x at bottom; inversion x; clarify. + +Tactic Notation "hinv" ident(a) := + (hinv a). +Tactic Notation "hinv" ident(a) ident(b) := + (hinv a; hinv b). +Tactic Notation "hinv" ident(a) ident(b) ident(c) := + (hinv a; hinv b c). +Tactic Notation "hinv" ident(a) ident(b) ident(c) ident(d) := + (hinv a b; hinv c d). + +Ltac hinvc x := hinv x; clear x. + +Tactic Notation "hinvc" ident(a) := + (hinvc a). +Tactic Notation "hinvc" ident(a) ident(b) := + (hinvc a; hinvc b). +Tactic Notation "hinvc" ident(a) ident(b) ident(c) := + (hinvc a; hinvc b c). +Tactic Notation "hinvc" ident(a) ident(b) ident(c) ident(d) := + (hinvc a b; hinvc c d). +Tactic Notation "hinvc" ident(a) ident(b) ident(c) ident(d) ident(e) := + (hinvc a b c; hinvc d e). + +Ltac simpls := simpl in *; try done. +Ltac ins := simpl in *; try done; intros. + +Tactic Notation "case_eq" constr(x) := case_eq (x). + +Tactic Notation "case_eq" constr(x) "as" simple_intropattern(H) := + destruct x as [] eqn: H; try done. + + +(* ************************************************************************** *) +(** * Basic simplication tactics *) +(* ************************************************************************** *) + +Ltac sflib__clarsimp1 := + clarify; (autorewrite with sflib in * ); try done; + match goal with + | [H: is_true ?x |- _] => rewrite H in *; sflib__clarsimp1 + | [H: ?x = true |- _] => rewrite H in *; sflib__clarsimp1 + | [H: ?x = false |- _] => rewrite H in *; sflib__clarsimp1 + | _ => clarify; auto 1 with sflib + end. + +Ltac clarsimp := intros; simpl in *; sflib__clarsimp1. + +Ltac autos := clarsimp; auto with sflib. + +(* hdesH, hdes: more general des *) + +Definition NW A (P: () -> A) : A := P (). + +Notation "<< x : t >>" := (NW (fun x => (t):Prop)) (at level 80, x name, no associativity). +Notation "<< t >>" := (NW (fun _ => t)) (at level 79, no associativity, only printing). +Notation "<< t >>" := (NW (fun _ => (t):Prop)) (at level 79, no associativity, only printing). + +Ltac unnw := unfold NW in *. +Ltac rednw := red; unnw. + +#[export] Hint Unfold NW: core. + +Ltac get_concl := lazymatch goal with [ |- ?G ] => G end. + +Ltac des1 := + match goal with + | H : NW _ |- _ => red in H + | H : exists x, NW (fun y => _) |- _ => + let x' := fresh x in let y' := fresh y in destruct H as [x' y']; red in y' + | H : exists x, ?p |- _ => + let x' := fresh x in destruct H as [x' H] + | H : ?p /\ ?q |- _ => + let x' := match p with | NW (fun z => _) => fresh z | _ => H end in + let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in + destruct H as [x' y']; + match p with | NW _ => red in x' | _ => idtac end; + match q with | NW _ => red in y' | _ => idtac end + | H : ?p <-> ?q |- _ => + let x' := match p with | NW (fun z => _) => fresh z | _ => H end in + let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in + destruct H as [x' y']; + match p with | NW _ => unfold NW at 1 in x'; red in y' | _ => idtac end; + match q with | NW _ => unfold NW at 1 in y'; red in x' | _ => idtac end + | H : ?p \/ ?q |- _ => + let x' := match p with | NW (fun z => _) => fresh z | _ => H end in + let y' := match q with | NW (fun z => _) => fresh z | _ => H end in + destruct H as [x' | y']; + [ match p with | NW _ => red in x' | _ => idtac end + | match q with | NW _ => red in y' | _ => idtac end] + end. + +Ltac des := repeat des1. + +Ltac desc := + repeat match goal with + | H : exists x, NW (fun y => _) |- _ => + let x' := fresh x in let y' := fresh y in destruct H as [x' y']; red in y' + | H : exists x, ?p |- _ => + let x' := fresh x in destruct H as [x' H] + | H : ?p /\ ?q |- _ => + let x' := match p with | NW (fun z => _) => fresh z | _ => H end in + let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in + destruct H as [x' y']; + match p with | NW _ => red in x' | _ => idtac end; + match q with | NW _ => red in y' | _ => idtac end + | H : is_true (_ && _) |- _ => + let H' := fresh H in case (sflib__andb_split H); clear H; intros H H' + | H : ?x = ?x |- _ => clear H + end. + +Ltac nbdes1 := + match goal with + | H : NW _ |- _ => red in H + | H : exists x, NW (fun y => _) |- _ => + let x' := fresh x in let y' := fresh y in destruct H as [x' y']; red in y' + | H : exists x, ?p |- _ => + let x' := fresh x in destruct H as [x' H] + | H : ?p /\ ?q |- _ => + let x' := match p with | NW (fun z => _) => fresh z | _ => H end in + let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in + destruct H as [x' y']; + match p with | NW _ => red in x' | _ => idtac end; + match q with | NW _ => red in y' | _ => idtac end + | H : ?p <-> ?q |- _ => + let x' := match p with | NW (fun z => _) => fresh z | _ => H end in + let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in + destruct H as [x' y']; + match p with | NW _ => unfold NW at 1 in x'; red in y' | _ => idtac end; + match q with | NW _ => unfold NW at 1 in y'; red in x' | _ => idtac end + (* | H : ?p \/ ?q |- _ => *) + (* let x' := match p with | NW (fun z => _) => fresh z | _ => H end in *) + (* let y' := match q with | NW (fun z => _) => fresh z | _ => H end in *) + (* destruct H as [x' | y']; *) + (* [ match p with | NW _ => red in x' | _ => idtac end *) + (* | match q with | NW _ => red in y' | _ => idtac end] *) + end. + +Ltac nbdes := repeat nbdes1. +Ltac rrnbdes H := move H at bottom; repeat red in H; nbdes. + +Ltac forall_split := + let H := fresh "__forall_split__" in first [intro; forall_split; match goal with [H:_|-_] => revert H end | split]. + +Definition _HID_ (A : Type) (a : A) := a. + +Ltac hdesHi H P x y := + let FF := fresh "__hdesfalse__" in + let TMP := fresh "__hdesHi__" in + let P1 := fresh "__hdesHi__" in + let P2 := fresh "__hdesHi__" in + evar (P1 : Prop); evar (P2 : Prop); + assert (TMP: False -> P) by + (intro FF; forall_split; + [ let G := get_concl in set (TMP := G); revert P1; instantiate (1:=G) + | let G := get_concl in set (TMP := G); revert P2; instantiate (1:=G) ]; + destruct FF); + try clear TMP; + try (try (match goal with [Def := ?G : _ |- _] => + match Def with P1 => + match goal with [_ : G |- _] => fail 4 end end end); + assert (x: P1) by (unfold P1; repeat (let x := fresh "__xhj__" in intro x; specialize (H x)); apply H)); + try unfold P1 in x; try clear P1; + try (try (match goal with [Def := ?G : _ |- _] => + match Def with P2 => + match goal with [_ : G |- _] => fail 4 end end end); + assert (y: P2) by (unfold P2; repeat (let x := fresh "__xhj__" in intro x; specialize (H x)); apply H)); + try unfold P2 in y; try clear P2; + fold (_HID_ P) in H; + try clear H. + +Ltac hdesHP H P := + let H' := fresh H in let H'' := fresh H in + match P with + | context[ NW (fun x => _) /\ NW (fun y => _) ] => + let x' := fresh x in let y' := fresh y in + hdesHi H P x' y'; red in x'; red in y' + | context[ NW (fun x => _) /\ _ ] => + let x' := fresh x in + hdesHi H P x' H'; red in x' + | context[ _ /\ NW (fun y => _) ] => + let y' := fresh y in + hdesHi H P H' y'; red in y' + | context[ _ /\ _ ] => + hdesHi H P H' H'' + | context[ NW (fun x => _) <-> NW (fun y => _) ] => + let x' := fresh x in let y' := fresh y in + hdesHi H P x' y'; red in x'; red in y' + | context[ NW (fun x => _) <-> _ ] => + let x' := fresh x in + hdesHi H P x' H'; red in x' + | context[ _ <-> NW (fun y => _) ] => + let y' := fresh y in + hdesHi H P H' y'; red in y' + | context[ _ <-> _ ] => + hdesHi H P H' H'' + end. + +Ltac hdesH H := let P := type of H in hdesHP H P; unfold _HID_ in *. + +(* +(* It works, but too slows *) +Ltac hdesF P := + match P with + | fun _ => _ /\ _ => idtac + | fun _ => _ <-> _ => idtac + | fun x => forall y : @?ty x, @?f x y => + let P' := eval cbv beta in (fun p : sigT ty => f (projT1 p) (projT2 p)) in + hdesF P' + end. + +Ltac hdes := + repeat match goal with | H : ?P |- _ => hdesF (fun _ : unit => P); hdesHP H P end; + unfold _HID_ in *. +*) + +Ltac hdesF P := + match P with | _ /\ _ => idtac | _ <-> _ => idtac | forall _, _ => + match P with | forall _, _ /\ _ => idtac | forall _, _ <-> _ => idtac | forall _ _, _ => + match P with | forall _ _, _ /\ _ => idtac | forall _ _, _ <-> _ => idtac | forall _ _ _, _ => + match P with | forall _ _ _, _ /\ _ => idtac | forall _ _ _, _ <-> _ => idtac | forall _ _ _ _, _ => + match P with | forall _ _ _ _, _ /\ _ => idtac | forall _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _, _ => + match P with | forall _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ => + match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac + end end end end end end end end end end end end end end end end end end end end end. + +(** Fail if hypothesis [H] doesn't exist. *) +Ltac check_hyp H := match H with _ => idtac end. + +(** Fail if hypothesis [H1] is not [H2]. *) +Ltac check_equal H1 H2 := match H1 with H2 => idtac end. + +Ltac hdes := + repeat match goal with | H : ?P |- _ => hdesF P; hdesHP H P end; + unfold _HID_ in *. +Ltac rdes H := red in H; des. +Ltac rrdes H := move H at bottom; repeat red in H; des. +Ltac rhdes H := red in H; hdes. +Ltac rrhdes H := check_hyp H; repeat red in H; hdes. + +Tactic Notation "rrdes" ident(a) := + (rrdes a). +Tactic Notation "rrdes" ident(a) ident(b) := + (rrdes a; rrdes b). +Tactic Notation "rrdes" ident(a) ident(b) ident(c) := + (rrdes a; rrdes b c). +Tactic Notation "rrdes" ident(a) ident(b) ident(c) ident(d) := + (rrdes a b; rrdes c d). + +(** Destruct the condition of an [if] expression occuring in the goal. *) +Ltac des_if := + match goal with + | [ |- context[if ?X then _ else _] ] => destruct X + end. +(* Ltac desE_if := *) +(* match goal with *) +(* | [ |- context[if ?X then _ else _] ] => let E := fresh X in destruct X eqn:E *) +(* end. *) + +(** Destruct the condition of an [if] expression occuring in the given hypothesis. *) +Ltac des_ifH H := + match goal with + | [ H' : context[if ?X then _ else _] |- _ ] => check_equal H' H; destruct X + end. + +(* TODO tactics such as these should always do clean at the end to remove junk like [H : x = x] *) +Ltac des_ifs := + clarify; + repeat + match goal with + | |- context[match ?x with _ => _ end] => + match (type of x) with + | { _ } + { _ } => destruct x; clarify + | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify + end + | H: context[ match ?x with _ => _ end ] |- _ => + match (type of x) with + | { _ } + { _ } => destruct x; clarify + | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify + end + end. + +Ltac desf := clarify; des; des_ifs. +Ltac isd := ins; desf. + +(** Create a copy of hypothesis [H]. *) +Tactic Notation "dup" hyp(H) := + let H' := fresh H in assert (H' := H). + +(* (** Call tactic [tac] on a copy of [H]. *) *) +(* Tactic Notation "dup" hyp(H) tactic(tac) := *) +(* let H' := fresh H in assert (H' := H); tac H'. *) + +Ltac clarassoc := clarsimp; autorewrite with sflib sflibA in *; try done. + +Ltac sflib__hacksimp1 := + clarsimp; + match goal with + | H: _ |- _ => solve [rewrite H; clear H; clarsimp + |rewrite <- H; clear H; clarsimp] + | _ => solve [f_equal; clarsimp] + end. + +Ltac hacksimp := + clarsimp; + try match goal with + | H: _ |- _ => solve [rewrite H; clear H; clarsimp + |rewrite <- H; clear H; clarsimp] + | |- context[if ?p then _ else _] => solve [destruct p; sflib__hacksimp1] + | _ => solve [f_equal; clarsimp] + end. + +(* ************************************************************************** *) +(** * Delineating cases in proofs *) +(* ************************************************************************** *) + +(** Named case tactics (taken from Libtactics) *) + +Tactic Notation "assert_eq" ident(x) constr(v) := + let H := fresh in + assert (x = v) as H by reflexivity; + clear H. + +Tactic Notation "Case_aux" ident(x) constr(name) := + first [ + set (x := name); move x at top + | assert_eq x name + | fail 1 "because we are working on a different case." ]. + +Ltac Case name := Case_aux case name. +Ltac SCase name := Case_aux subcase name. +Ltac SSCase name := Case_aux subsubcase name. +Ltac SSSCase name := Case_aux subsubsubcase name. +Ltac SSSSCase name := Case_aux subsubsubsubcase name. + +(** Lightweight case tactics (without names) *) + +Tactic Notation "-" tactic(c) := + first [ + assert (WithinCaseM := True); move WithinCaseM at top + | fail 1 "because we are working on a different case." ]; c. + +Tactic Notation "+" tactic(c) := + first [ + assert (WithinCaseP := True); move WithinCaseP at top + | fail 1 "because we are working on a different case." ]; c. + +Tactic Notation "*" tactic(c) := + first [ + assert (WithinCaseS := True); move WithinCaseS at top + | fail 1 "because we are working on a different case." ]; c. + +Tactic Notation ":" tactic(c) := + first [ + assert (WithinCaseC := True); move WithinCaseC at top + | fail 1 "because we are working on a different case." ]; c. + +(* ************************************************************************** *) +(** * Exploiting a hypothesis *) +(* ************************************************************************** *) + +(** Exploit an assumption (adapted from CompCert). *) + +Tactic Notation "exploit" uconstr(t) := + refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _ _) _) + || refine ((fun x y => y x) (t _ _ _) _) + || refine ((fun x y => y x) (t _ _) _) + || refine ((fun x y => y x) (t _) _). + +(* When 'exploit x' generates too many sub goals, try 'hexploit x' *) + +Lemma mp: forall P Q: Type, P -> (P -> Q) -> Q. +Proof. intuition. Defined. + +Lemma mp': forall P Q : Type, (P -> Q) -> P -> Q. +Proof. intuition. Qed. + +Ltac hexploit x := eapply mp; [eapply x|]. +Ltac hexploit' x := let H := fresh in set (H := x); clear H; eapply mp; [eapply x|]. + +(* set_prop N T A performs 'assert (A : P); [|set (N := T A)]' when T is a term of type (P -> _) *) + +Ltac set_prop N T A := + let b := fresh in let ty := type of T in + match ty with (forall (_:?P), _) => assert (A: P); [|set (N := T A)] end. + +(* ************************************************************************** *) +(** * Induction tactics *) +(* ************************************************************************** *) + +Tactic Notation "induction" "[" ident_list(y) "]" ident(x) := + first [ try (intros until x); revert y; induction x + | red; try (intros until x); revert y; induction x ]. + +Tactic Notation "induction" "[" ident_list(y) "]" ident(x) "[" ident(z) "]" := + first [ try (intros until x); revert y; induction x; destruct z + | red; try (intros until x); revert y; induction x; destruct z ]. + +(** Versions with hacksimp *) + +Tactic Notation "induct" ident(x) := induction x; hacksimp. + +Tactic Notation "induct" ident(x) "[" ident(z) "]" := + induction x; destruct z; hacksimp. + +Tactic Notation "induct" "[" ident_list(y) "]" ident(x) := + first [ try (intros until x); revert y; induction x; hacksimp + | red; try (intros until x); revert y; induction x; hacksimp ]. + +Tactic Notation "induct" "[" ident_list(y) "]" ident(x) "[" ident(z) "]" := + first [ try (intros until x); revert y; induction x; destruct z; hacksimp + | red; try (intros until x); revert y; induction x; destruct z; hacksimp ]. + +Tactic Notation "edestructs" ident(a) := + (edestruct a). +Tactic Notation "edestructs" ident(a) ident(b) := + (edestruct a; edestruct b). +Tactic Notation "edestructs" ident(a) ident(b) ident(c) := + (edestruct a; edestructs b c). +Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) := + (edestruct a; edestructs b c d). +Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) ident(e) := + (edestruct a; edestructs b c d e). +Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) := + (edestruct a; edestructs b c d e f). +Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) := + (edestruct a; edestructs b c d e f g). +Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) := + (edestruct a; edestructs b c d e f g h). +Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) ident(i) := + (edestruct a; edestructs b c d e f g h i). +Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) ident(i) ident(j) := + (edestruct a; edestructs b c d e f g h i j). + +Tactic Notation "destructs" ident(a) := + (destruct a). +Tactic Notation "destructs" ident(a) ident(b) := + (destruct a; destruct b). +Tactic Notation "destructs" ident(a) ident(b) ident(c) := + (destruct a; destructs b c). +Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) := + (destruct a; destructs b c d). +Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) ident(e) := + (destruct a; destructs b c d e). +Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) := + (destruct a; destructs b c d e f). +Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) := + (destruct a; destructs b c d e f g). +Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) := + (destruct a; destructs b c d e f g h). +Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) ident(i) := + (destruct a; destructs b c d e f g h i). +Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) ident(i) ident(j) := + (destruct a; destructs b c d e f g h i j). + +Tactic Notation "depdes" ident(_something_which_shold_not_occur_in_the_goal_) := + (let _x_ := type of _something_which_shold_not_occur_in_the_goal_ + in dependent destruction _something_which_shold_not_occur_in_the_goal_). +Tactic Notation "depdes" ident(a) ident(b) := + (depdes a; depdes b). +Tactic Notation "depdes" ident(a) ident(b) ident(c) := + (depdes a; depdes b c). +Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) := + (depdes a; depdes b c d). +Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) ident(e) := + (depdes a; depdes b c d e). +Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) := + (depdes a; depdes b c d e f). +Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) := + (depdes a; depdes b c d e f g). +Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) := + (depdes a; depdes b c d e f g h). +Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) ident(i) := + (depdes a; depdes b c d e f g h i). +Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) ident(i) ident(j) := + (depdes a; depdes b c d e f g h i j). + +Tactic Notation "depgen" ident(x) := generalize dependent x. + +(* eappleft, eappright *) + +Ltac eappleft H := + let X := fresh "__lem__" in let X1 := fresh "__lem__" in let X2 := fresh "__lem__" in + assert (X:= H); let P := type of X in hdesHi X P X1 X2; + eapply X1; clear X1 X2. + +Ltac eappright H := + let X := fresh "__lem__" in let X1 := fresh "__lem__" in let X2 := fresh "__lem__" in + assert (X:= H); let P := type of X in hdesHi X P X1 X2; + eapply X2; clear X1 X2. + +(* guard for simpl *) + +(* for Coq8.4 *) + +Definition __guard__ A (a : A) : A := a. +Definition __GUARD__ A (a : A) : A := a. +Arguments __guard__ A a : simpl never. +Arguments __GUARD__ A a : simpl never. + +Tactic Notation "guard" constr(t) "in" hyp(H) := fold (__guard__ t) in H. +Tactic Notation "guardH" hyp(H) := let t := type of H in guard t in H. +Tactic Notation "guard" := + repeat match goal with [H: ?P |- _] => + try (match P with __guard__ _ => fail 2 end); guardH H + end. +Tactic Notation "sguard" constr(t) "in" hyp(H) := fold (__GUARD__ t) in H. +Tactic Notation "sguard" "in" hyp(H) := let t := type of H in sguard t in H. + +Ltac unguard := unfold __guard__ in *. +Ltac unguardH H := unfold __guard__ in H. +Ltac unsguard H := unfold __GUARD__ in H. + +Ltac desH H := guard; unguardH H; des; unguard. + +Ltac splits := + intros; unfold NW; + repeat match goal with + | [ |- _ /\ _ ] => split + end. +Ltac esplits := + intros; unfold NW; + repeat match goal with + | [ |- @ex _ _ ] => eexists + | [ |- _ /\ _ ] => split + | [ |- @sig _ _ ] => eexists + | [ |- @sigT _ _ ] => eexists + | [ |- @prod _ _ ] => split + end. + +Tactic Notation "replace_all" constr(e) := repeat ( + let X := fresh in assert (X: e) by (clarify; eauto; done); + first [rewrite !X | setoid_rewrite X]; clear X). + +Lemma all_conj_dist: forall A (P Q: A -> Prop), + (forall a, P a /\ Q a) -> (forall a, P a) /\ (forall a, Q a). +Proof. intros; hdes; eauto. Qed. + +(* extensionalities *) + +Tactic Notation "extensionalities" := + repeat let x := fresh in extensionality x. +Tactic Notation "extensionalities" ident(a) := + (extensionality a). +Tactic Notation "extensionalities" ident(a) ident(b) := + (extensionality a; extensionality b). +Tactic Notation "extensionalities" ident(a) ident(b) ident(c) := + (extensionality a; extensionalities b c). +Tactic Notation "extensionalities" ident(a) ident(b) ident(c) ident(d) := + (extensionality a; extensionalities b c d). +Tactic Notation "extensionalities" ident(a) ident(b) ident(c) ident(d) ident(e) := + (extensionality a; extensionalities b c d e). +Tactic Notation "extensionalities" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) := + (extensionality a; extensionalities b c d e f). + +(* short for common tactics *) + +Tactic Notation "inst" := instantiate. +Tactic Notation "econs" := econstructor. +Tactic Notation "econs" int_or_var(x) := econstructor x. +Tactic Notation "i" := intros. +Tactic Notation "ii" := repeat intro. +Tactic Notation "s" := simpl. +Tactic Notation "s" ident(a) := simpl a. +Tactic Notation "s" constr(t) := simpl t. +Tactic Notation "s" "in" hyp(H) := simpl in H. +Tactic Notation "ss" := simpls. +Tactic Notation "r" := red. +Tactic Notation "r" "in" hyp(H) := red in H. +Tactic Notation "rr" := repeat red. +Tactic Notation "rr" "in" hyp(H) := repeat red in H. + +(* running a tactic selectively on subgoals *) + +Definition __mark__ A (a : A) : A := a. + +Tactic Notation "M" := + match goal with [|-?G] => fold (__mark__ G) end. + +Tactic Notation "Mdo" tactic(tac) := + first [ try match goal with [|- __mark__ _ ] => fail 2 end | unfold __mark__; tac ]. + +Tactic Notation "Mskip" tactic(tac) := + first [ match goal with [|- __mark__ _ ] => unfold __mark__ end | tac ]. + +Tactic Notation "Mfirst" tactic(main) ";;" tactic(post) := + main; (Mdo (post; M)); (Mskip post). + +(* revert until *) + +Ltac on_last_hyp tac := + match goal with [ H : _ |- _ ] => first [ tac H | fail 1 ] end. + +Ltac revert_until id := + on_last_hyp ltac:(fun id' => + match id' with + | id => idtac + | _ => revert id' ; revert_until id + end). + +Open Scope string_scope. +Open Scope list_scope. + +Fixpoint beq_str (s1 s2: string) : bool := + match s1, s2 with + | "", "" => true + | String a s1', String b s2' => if Ascii.ascii_dec a b then beq_str s1' s2' else false + | _, _ => false + end. + +Ltac uf := (autounfold with * in *). + +Tactic Notation "patout" constr(z) "in" hyp(a) := + pattern z in a; match goal with [a:=?f z|-_] => unfold a; clear a; set (a:=f) end. + +Ltac clear_upto H := + repeat (match goal with [Hcrr : _ |- _ ] => first [ check_equal Hcrr H; fail 2 + | clear Hcrr ] end). + +Definition _Evar_sflib_ (A:Type) (x:A) := x. + +Tactic Notation "hide_evar" int_or_var(n) := let QQ := fresh "QQ" in + hget_evar n; intro; + lazymatch goal with [ H := ?X |- _] => + set (QQ := X) in *; fold (_Evar_sflib_ X) in QQ; clear H + end. + +Ltac hide_evars := repeat (hide_evar 1). + +Ltac show_evars := repeat (match goal with [ H := @_Evar_sflib_ _ _ |- _ ] => unfold + _Evar_sflib_ in H; unfold H in *; clear H end). + +Ltac revert1 := match goal with [H: _|-_] => revert H end. + +Lemma eqimpl: forall P Q : Prop, P = Q -> P -> Q. +Proof. by i; subst; auto. Qed. + +Ltac ginduction H := + move H at top; revert_until H; induction H. + +Tactic Notation "greflgen" constr(t) "as" ident(g) := + let EQ := fresh "XEQ" in + generalize (eq_refl t); generalize t at -2 as g + ; intros ? EQ ?; revert EQ. + +Ltac eadmit := + exfalso; clear; admit. + +Ltac special H := + (* eapply mp; refine (H _). *) + match type of H with + | ?A -> ?B => + let a := fresh in assert (a: A); [|specialize (H a)] + end. + +(** Useful for e.g. [ex @nil]. *) +Ltac ex x := eapply (ex_intro _ (x _)). + +Ltac inst_pairs := + repeat first + [instantiate (9 := (_, _)) + |instantiate (8 := (_, _)) + |instantiate (7 := (_, _)) + |instantiate (6 := (_, _)) + |instantiate (5 := (_, _)) + |instantiate (4 := (_, _)) + |instantiate (3 := (_, _)) + |instantiate (2 := (_, _)) + |instantiate (1 := (_, _))]. + +(* Problem: unfold fst doesn't always result in a lambda *) +(* Ltac fold_proj := *) +(* try match goal with |- context[fun _ : ?A * ?B => _] => *) +(* first [fold (@fst A B) | fold (@snd A B)]; fail *) +(* end. *) +(* Ltac fold_projH H := *) +(* match type of H with | context[fun _ : ?A * ?B => _] => *) +(* first [fold (@fst A B) in H | fold (@snd A B) in H]; fail *) +(* end. *) +(* Ltac simpl_proj := *) +(* unfold fst in *; Hdo fold_projH; fold_proj. *) + +(* Lemma simpl_fst: forall A (a: A) B (b: B), *) +(* fst (a, b) = a. *) +(* Proof. *) +(* auto. *) +(* Qed. *) + +(* Lemma simpl_snd: forall B (b: B) A (a: A), *) +(* snd (a, b) = b. *) +(* Proof. *) +(* auto. *) +(* Qed. *) + +Ltac simpl_proj := + do 5 (simpl (fst (_, _)) in *; simpl (snd (_, _)) in *). + (* ; repeat first [rewrite !simpl_fst | rewrite !simpl_snd] *) + (* ; Hdo (fun H => repeat first [rewrite !simpl_fst in H | rewrite !simpl_snd in H]). *) + +Ltac clean := + repeat match goal with + | H: True |- _ + => clear H + | H: ?x = ?y |- _ + => try (has_evar x; fail 2); try (has_evar y; fail 2); + change x with y in H; clear H + end + ; simpl_proj. + (* without the evar check, clean removes equations such as the following: + X : length (getVal ?28711 ?28712 ?28713 ?28714) = S n *) + + +Tactic Notation "lhs" tactic(tac) := + match goal with |- ?op ?lhs ?rhs => + let tmp := fresh in set (tmp := rhs); tac; unfold tmp; clear tmp + end. + +(* Variant of lhs that allows prover to combine lhs/rhs tactics in + * tacticals. For example: + * lhs (rewrite blah); rhs (rewrite blah). + * is allowed. lhs fails because the precedence for the tactic + * was higher than the ";" and so tac = rewrite blah; rhs (rewrite blah). + * TODO: Check whether it's safe to override the definition of lhs/rhs. + *) +Tactic Notation "lhs3" tactic3(tac) := + match goal with |- ?op ?lhs ?rhs => + let tmp := fresh in set (tmp := rhs); tac; unfold tmp; clear tmp + end. + +Tactic Notation "rhs" tactic(tac) := + match goal with |- ?op ?lhs ?rhs => + let tmp := fresh in set (tmp := lhs); tac; unfold tmp; clear tmp + end. + +(* See the comment for lhs3. *) +Tactic Notation "rhs3" tactic3(tac) := + match goal with |- ?op ?lhs ?rhs => + let tmp := fresh in set (tmp := lhs); tac; unfold tmp; clear tmp + end. + + +(* TODO generalize to hyps *) + + +(** Execute a tactic only if the goal contains no evars. *) +Tactic Notation "safe" tactic(tac) := + try match goal with |- ?G => try (has_evar G; fail 2); tac end. + + +(** Rename a hypothesis to a fresh name. *) +Ltac ren H := + let X := fresh H in rename H into X. + +(* (** Instantiate consecutive evars. *) *) +(* Tactic Notation "insts" constr(terms) := *) +(* Hdo (fun x => instantiate (1 := x)) terms. *) +(* (* TODO this is not very useful after all *) *) + + + +(** Automation using econstructor. + What it does is clear from the definition below. *) +Tactic Notation "econsby" tactic(tac) := + first [econstructor 1; (by tac) + |econstructor 2; (by tac) + |econstructor 3; (by tac) + |econstructor 4; (by tac) + |econstructor 5; (by tac) + |econstructor 6; (by tac) + |econstructor 7; (by tac) + |econstructor 8; (by tac) + |econstructor 9; (by tac) + |econstructor 10; (by tac) + |econstructor 11; (by tac) + |econstructor 12; (by tac) + |econstructor 13; (by tac) + |econstructor 14; (by tac) + |econstructor 15; (by tac) + |econstructor 16; (by tac) + |econstructor 17; (by tac) + |econstructor 18; (by tac) + |econstructor 19; (by tac) + |econstructor 20; (by tac) + ].