From c539a39539631fc8cb3226ba74afd50d91f97fcf Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 28 Mar 2023 11:50:37 +0200 Subject: [PATCH 001/174] WIP --- security/Backtranslation.v | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index f87495e928..6c27af166b 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -29,7 +29,8 @@ Section Backtranslation. 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) + | EVfloat f => Econst_float f (Tfloat F64 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)) From 8661f903bf6cac6f6066885fd87223964596352d Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 29 Mar 2023 19:59:10 +0200 Subject: [PATCH 002/174] resolved admit --- security/Backtranslation.v | 99 ++++++++++++++++++++------------------ 1 file changed, 53 insertions(+), 46 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 6c27af166b..d074d4a66f 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -29,13 +29,14 @@ Section Backtranslation. 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) (* | EVfloat f => Econst_float f (Tfloat F32 noattr) *) + | EVfloat f => Econst_float f (Tfloat F64 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) + (* | 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) *) + | EVptr_global id ofs => ptr_of_id_ofs id ofs end. Definition list_eventval_to_list_expr (vs: list eventval): list expr := @@ -74,18 +75,19 @@ Section Backtranslation. | Event_return cp cp' v => code_of_return cp cp' v end. - 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 + 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 (bt_env.(local_counter) cp) 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)) + (Ebinop Cop.Oadd (Evar (bt_env.(local_counter) cp) type_counter) one type_counter)) s_then) (* if false *) s_else. @@ -108,30 +110,29 @@ Section Backtranslation. 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: + Lemma switch_clause_spec p (cp: compartment) f (e: env) le m b (n: int64) (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 + 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 (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') 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. + 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 (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 cp s res := (Z.pred (fst res), switch_clause cp (Z.pred (fst res)) s (snd res)). @@ -146,41 +147,47 @@ Section Backtranslation. simpl; lia. Qed. - Lemma switch_spec_else p (cp: compartment) f Kstop (e: env) le m b (n: Z) ss s_else: - n >= 0 -> + Lemma switch_spec_else + p (cp: compartment) f Kstop (e: env) le m b (n: Z) ss s_else + (WF: Z.of_nat (length ss) < Int64.modulus - 1) + (RANGE: Z.of_nat (length ss) <= n < Int64.modulus) + : 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 -> + Mem.valid_access m Mint64 b 0 Writable (Some cp) -> + Mem.loadv Mint64 m (Vptr b Ptrofs.zero) (Some cp) = Some (Vlong (Int64.repr n)) -> Star (Clight.semantics1 p) (State f (switch cp ss s_else) Kstop e le m) E0 (State f s_else Kstop 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 -> + (* 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. + { 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. + simpl. simpl in RA1, LE1. rewrite fst_switch, <- Z.sub_succ_r. take_step. - { rewrite Int.eq_false. reflexivity. + { 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. Section WithTrace. From 5811d578d0d5f2942f90d8d8a7ce62c258ef10fe Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 30 Mar 2023 11:42:10 +0200 Subject: [PATCH 003/174] proved switch related lemmas --- security/Backtranslation.v | 175 +++++++++++++++++++++++-------------- 1 file changed, 110 insertions(+), 65 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index d074d4a66f..ab1e389758 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -13,67 +13,7 @@ Section Backtranslation. Variable bt_env: backtranslation_environment. - 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) *) - | EVfloat f => Econst_float f (Tfloat F64 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) *) - | EVptr_global id ofs => ptr_of_id_ofs id ofs - 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). - - 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. + (** switch statement; use to convert a trace to a code **) Definition type_counter: type := Tlong Unsigned noattr. Definition type_bool: type := Tint IBool Signed noattr. @@ -148,13 +88,13 @@ Section Backtranslation. Qed. Lemma switch_spec_else - p (cp: compartment) f Kstop (e: env) le m b (n: Z) ss s_else - (WF: Z.of_nat (length ss) < Int64.modulus - 1) + p (cp: compartment) f (e: env) le m b (n: Z) ss s_else + (WF: Z.of_nat (length ss) < Int64.modulus) (RANGE: Z.of_nat (length ss) <= n < Int64.modulus) : cp = comp_of f -> e ! (bt_env.(local_counter) cp) = Some (b, type_counter) -> - Mem.valid_access m Mint64 b 0 Writable (Some cp) -> + (* Mem.valid_access m Mint64 b 0 Writable (Some cp) -> *) Mem.loadv Mint64 m (Vptr b Ptrofs.zero) (Some cp) = Some (Vlong (Int64.repr n)) -> Star (Clight.semantics1 p) (State f (switch cp ss s_else) Kstop e le m) @@ -165,7 +105,6 @@ Section Backtranslation. assert (G: forall 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 @@ -189,6 +128,112 @@ Section Backtranslation. now apply G; lia. Qed. + Let nat64 n := Int64.repr (Z.of_nat n). + + Lemma switch_spec + p (cp: compartment) f (e: env) le m b + ss s ss' s_else + (WF: Z.of_nat (length (ss ++ s :: ss')) < Int64.modulus) + : + cp = comp_of f -> + e ! (bt_env.(local_counter) cp) = Some (b, type_counter) -> + 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 (Clight.semantics1 p) + (State f (switch cp (ss ++ s :: ss') s_else) Kstop e le m) + E0 + (State f s Kstop e le m'). + Proof. + intros. + assert (Eswitch : + exists s_else', + switch cp (ss ++ s :: ss') s_else = + switch cp ss (switch_clause cp (Z.of_nat (length ss)) s s_else')). + { unfold switch. rewrite fold_right_app, app_length. simpl. + exists (snd (fold_right (switch_add_statement cp) (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 p cp f e le m b (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. + + (** converting trace to code **) + + 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) *) + | EVfloat f => Econst_float f (Tfloat F64 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) *) + | EVptr_global id ofs => ptr_of_id_ofs id ofs + 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). + + 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 WithTrace. From 7fe40a59f0c20a12e77fef3ed08ddad578e38391 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 30 Mar 2023 18:07:09 +0200 Subject: [PATCH 004/174] WIP --- security/Backtranslation.v | 69 ++++++++++++++++++++++++++++++++------ 1 file changed, 58 insertions(+), 11 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index ab1e389758..f08420ae68 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -171,32 +171,79 @@ Section Backtranslation. (** converting trace to code **) + 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. + 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) *) | EVfloat f => Econst_float f (Tfloat F64 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) *) | EVptr_global id ofs => ptr_of_id_ofs id ofs end. + Definition wf_eventval (ge: Senv.t) (v: eventval): Prop := + match v with + | EVptr_global id _ => (Senv.public_symbol ge id = true) + | _ => True + end. + + Lemma eventval_to_expr_inv + ge env cp le m + ev exp v ty + (CONV: eventval_to_expr ev = exp) + (EVAL: eval_expr ge env cp le m exp v) + (TYPE: typ_of_type (eventval_to_type ev) = ty) + : + eventval_match ge ev ty v. + Proof. + subst. destruct ev; simpl in *. + - inversion EVAL; subst; simpl in *; try constructor. inversion H. + - inversion EVAL; subst; simpl in *; try constructor. inversion H. + - inversion EVAL; subst; simpl in *; try constructor. inversion H. + - inversion EVAL; subst; simpl in *; try constructor. inversion H. + - inversion EVAL; subst; simpl in *; try constructor. + + inversion H5; subst; simpl in *. + 2:{ inversion H. } + clear H5. inversion H4; subst; simpl in *. + 2:{ + + + inversion H. + + + (* | step_call : forall (f : function) (optid : option ident) (a : expr) (al : list expr) (k : cont) (e : env) (le : temp_env) (m : mem) (tyargs : typelist) (tyres : type) (cconv : calling_convention) *) + (* (vf : val) (vargs : list val) (fd : fundef) (t : trace), *) + (* Cop.classify_fun (typeof a) = Cop.fun_case_f tyargs tyres cconv -> *) + (* eval_expr ge e (comp_of f) le m a vf -> *) + (* eval_exprlist ge e (comp_of f) le m al tyargs vargs -> *) + (* Genv.find_funct ge vf = Some fd -> *) + (* type_of_fundef fd = Tfunction tyargs tyres cconv -> *) + (* Genv.allowed_call ge (comp_of f) vf -> *) + (* (Genv.type_of_call ge (comp_of f) (Genv.find_comp ge vf) = Genv.CrossCompartmentCall -> Forall not_ptr vargs) -> *) + (* call_trace ge (comp_of f) (Genv.find_comp ge vf) vf vargs (typlist_of_typelist tyargs) t -> *) + (* step ge function_entry (State f (Scall optid a al) k e le m) t (Callstate fd vargs (Kcall optid f e le k) m) *) + + + 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 list_eventval_to_list_expr (vs: list eventval): list expr := List.map eventval_to_expr vs. From aa0d40b048e9a4c8417eeba8006f4bb2fc9edd29 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 30 Mar 2023 20:02:44 +0200 Subject: [PATCH 005/174] WIP --- security/Backtranslation.v | 56 ++++++++++++++++++++++++++++++-------- 1 file changed, 44 insertions(+), 12 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index f08420ae68..b9ff65a4a6 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -181,10 +181,17 @@ Section Backtranslation. end. 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). + 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). Definition eventval_to_expr (v: eventval): expr := match v with @@ -195,7 +202,7 @@ Section Backtranslation. | EVptr_global id ofs => ptr_of_id_ofs id ofs end. - Definition wf_eventval (ge: Senv.t) (v: eventval): Prop := + Definition wf_eventval (ge: genv) (v: eventval): Prop := match v with | EVptr_global id _ => (Senv.public_symbol ge id = true) | _ => True @@ -204,6 +211,7 @@ Section Backtranslation. Lemma eventval_to_expr_inv ge env cp le m ev exp v ty + (WFEV: wf_eventval ge ev) (CONV: eventval_to_expr ev = exp) (EVAL: eval_expr ge env cp le m exp v) (TYPE: typ_of_type (eventval_to_type ev) = ty) @@ -215,15 +223,39 @@ Section Backtranslation. - inversion EVAL; subst; simpl in *; try constructor. inversion H. - inversion EVAL; subst; simpl in *; try constructor. inversion H. - inversion EVAL; subst; simpl in *; try constructor. inversion H. - - inversion EVAL; subst; simpl in *; try constructor. - + inversion H5; subst; simpl in *. + - unfold ptr_of_id_ofs in EVAL. destruct Archi.ptr64 eqn:ARCH. + + inversion EVAL; subst; simpl in *; try constructor. + 2:{ inversion H. } + inversion H5; subst; simpl in *. 2:{ inversion H. } clear H5. inversion H4; subst; simpl in *. - 2:{ - - - inversion H. - + 2:{ inversion H. } + clear H4. inversion H2; subst; simpl. + { admit. } + { inversion H6. + rewrite Ptrofs.mul_commut, Ptrofs.mul_one. + rewrite Ptrofs.add_zero_l. + replace (Ptrofs.of_int64 (Ptrofs.to_int64 i0)) with i0. + constructor; auto. + symmetry. apply Ptrofs.of_int64_to_int64. auto. + } + + inversion EVAL; subst; simpl in *; try constructor. + 2:{ inversion H. } + inversion H5; subst; simpl in *. + 2:{ inversion H. } + clear H5. inversion H4; subst; simpl in *. + 2:{ inversion H. } + clear H4. inversion H2; subst; simpl. + { admit. } + { inversion H6. + rewrite Ptrofs.mul_commut, Ptrofs.mul_one. + rewrite Ptrofs.add_zero_l. + replace (Ptrofs.of_ints (Ptrofs.to_int i0)) with i0. + constructor; auto. + symmetry. apply Ptrofs.agree32_of_ints_eq; auto. + apply Ptrofs.agree32_to_int; auto. + } + Qed. (* | step_call : forall (f : function) (optid : option ident) (a : expr) (al : list expr) (k : cont) (e : env) (le : temp_env) (m : mem) (tyargs : typelist) (tyres : type) (cconv : calling_convention) *) (* (vf : val) (vargs : list val) (fd : fundef) (t : trace), *) From 88902bc85d0b86fa6f18bdd811411b17c5c66256 Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 31 Mar 2023 16:24:48 +0200 Subject: [PATCH 006/174] WIP - program from trace --- Makefile | 2 +- security/Backtranslation.v | 125 +++++++++++++++++++++++++++++++------ 2 files changed, 107 insertions(+), 20 deletions(-) diff --git a/Makefile b/Makefile index 7cae286509..8a448e3df1 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 Backtranslation.v # Parser diff --git a/security/Backtranslation.v b/security/Backtranslation.v index b9ff65a4a6..289b483ac3 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -202,16 +202,16 @@ Section Backtranslation. | EVptr_global id ofs => ptr_of_id_ofs id ofs end. - Definition wf_eventval (ge: genv) (v: eventval): Prop := + Definition wf_eventval (ge: genv) (e: env) (v: eventval): Prop := match v with - | EVptr_global id _ => (Senv.public_symbol ge id = true) + | EVptr_global id _ => (e ! id = None) /\ (Senv.public_symbol ge id = true) | _ => True end. Lemma eventval_to_expr_inv ge env cp le m ev exp v ty - (WFEV: wf_eventval ge ev) + (WFEV: wf_eventval ge env ev) (CONV: eventval_to_expr ev = exp) (EVAL: eval_expr ge env cp le m exp v) (TYPE: typ_of_type (eventval_to_type ev) = ty) @@ -223,7 +223,7 @@ Section Backtranslation. - inversion EVAL; subst; simpl in *; try constructor. inversion H. - inversion EVAL; subst; simpl in *; try constructor. inversion H. - inversion EVAL; subst; simpl in *; try constructor. inversion H. - - unfold ptr_of_id_ofs in EVAL. destruct Archi.ptr64 eqn:ARCH. + - destruct WFEV as [WFEV1 WFEV2]. unfold ptr_of_id_ofs in EVAL. destruct Archi.ptr64 eqn:ARCH. + inversion EVAL; subst; simpl in *; try constructor. 2:{ inversion H. } inversion H5; subst; simpl in *. @@ -231,7 +231,7 @@ Section Backtranslation. clear H5. inversion H4; subst; simpl in *. 2:{ inversion H. } clear H4. inversion H2; subst; simpl. - { admit. } + { rewrite WFEV1 in H4. inversion H4. } { inversion H6. rewrite Ptrofs.mul_commut, Ptrofs.mul_one. rewrite Ptrofs.add_zero_l. @@ -246,7 +246,7 @@ Section Backtranslation. clear H5. inversion H4; subst; simpl in *. 2:{ inversion H. } clear H4. inversion H2; subst; simpl. - { admit. } + { rewrite WFEV1 in H4. inversion H4. } { inversion H6. rewrite Ptrofs.mul_commut, Ptrofs.mul_one. rewrite Ptrofs.add_zero_l. @@ -257,19 +257,6 @@ Section Backtranslation. } Qed. - (* | step_call : forall (f : function) (optid : option ident) (a : expr) (al : list expr) (k : cont) (e : env) (le : temp_env) (m : mem) (tyargs : typelist) (tyres : type) (cconv : calling_convention) *) - (* (vf : val) (vargs : list val) (fd : fundef) (t : trace), *) - (* Cop.classify_fun (typeof a) = Cop.fun_case_f tyargs tyres cconv -> *) - (* eval_expr ge e (comp_of f) le m a vf -> *) - (* eval_exprlist ge e (comp_of f) le m al tyargs vargs -> *) - (* Genv.find_funct ge vf = Some fd -> *) - (* type_of_fundef fd = Tfunction tyargs tyres cconv -> *) - (* Genv.allowed_call ge (comp_of f) vf -> *) - (* (Genv.type_of_call ge (comp_of f) (Genv.find_comp ge vf) = Genv.CrossCompartmentCall -> Forall not_ptr vargs) -> *) - (* call_trace ge (comp_of f) (Genv.find_comp ge vf) vf vargs (typlist_of_typelist tyargs) t -> *) - (* step ge function_entry (State f (Scall optid a al) k e le m) t (Callstate fd vargs (Kcall optid f e le k) m) *) - - Fixpoint list_eventval_to_typelist (vs: list eventval): typelist := match vs with | nil => Tnil @@ -312,7 +299,107 @@ Section Backtranslation. | Event_return cp cp' v => code_of_return cp cp' v end. + (* A while(1)-loop with a big switch inside it *) + Definition code_of_trace cp (t: trace): statement := + Swhile (Econst_int Int.one (Tint I32 Signed noattr)) (switch cp (map code_of_event t) (Sreturn None)). + + (** Projection of the trace according to compartments **) + + (* Definition curr_comp_of_event (e: event): option compartment := *) + (* match e with *) + (* | Event_call cp cp' id vs => Some cp *) + (* | Event_return cp cp' v => Some cp' *) + (* | _ => None *) + (* end. *) + + (* Definition next_comp_of_event (e: event): option compartment := *) + (* match e with *) + (* | Event_call cp cp' id vs => Some cp' *) + (* | Event_return cp cp' v => Some cp *) + (* | _ => None *) + (* end. *) + + Definition comp_of_event (e: event): option (compartment * compartment) := + match e with + | Event_call cp cp' id vs => Some (cp, cp') + | Event_return cp cp' v => Some (cp', cp) + | _ => None + end. + + (* Instance has_comp_event: has_comp event := *) + + Definition comp_proj_trace (cp: compartment) (t: trace): compartment * trace := + fold_right + (fun ev '(cp_now, sub) => match comp_of_event ev with + | Some (cp_curr, cp_next) => (cp_next, if (Pos.eqb cp_curr cp) then (ev :: sub) else sub) + | None => (cp_now, if (Pos.eqb cp_now cp) then (ev :: sub) else sub) + end) + (default_compartment, nil) t. + + Definition comp_subtrace (cp: compartment) (t: trace) := + snd (comp_proj_trace cp t). + + Definition code_of_subtrace cp t := + code_of_trace cp (comp_subtrace cp t). + + (* TODO *) + + (* old CCS version *) + Lemma comp_subtrace_app (C: Component.id) (t1 t2: trace) : + comp_subtrace C (t1 ++ t2) = comp_subtrace C t1 ++ comp_subtrace C t2. + Proof. apply: filter_cat. Qed. + + Definition procedures_of_trace (t: trace) : NMap (NMap expr) := + mapim (fun C Ciface => + let procs := + if C == Component.main then + Procedure.main |: Component.export Ciface + else Component.export Ciface in + mkfmapf (fun P => procedure_of_trace C P t) procs) + intf. + + Definition valid_procedure C P := + C = Component.main /\ P = Procedure.main + \/ exported_procedure intf C P. + + Lemma find_procedures_of_trace_exp (t: trace) C P : + exported_procedure intf C P -> + find_procedure (procedures_of_trace t) C P + = Some (procedure_of_trace C P t). + Proof. + intros [CI [C_CI CI_P]]. + unfold find_procedure, procedures_of_trace. + rewrite mapimE C_CI /= mkfmapfE. + case: eqP=> _; last by rewrite CI_P. + by rewrite in_fsetU1 CI_P orbT. + Qed. + + Lemma find_procedures_of_trace_main (t: trace) : + find_procedure (procedures_of_trace t) Component.main Procedure.main + = Some (procedure_of_trace Component.main Procedure.main t). + Proof. + rewrite /find_procedure /procedures_of_trace. + rewrite mapimE eqxx. + case: (intf Component.main) (has_main)=> [Cint|] //= _. + by rewrite mkfmapfE in_fsetU1 eqxx. + Qed. + + Lemma find_procedures_of_trace (t: trace) C P : + valid_procedure C P -> + find_procedure (procedures_of_trace t) C P + = Some (procedure_of_trace C P t). + Proof. + by move=> [[-> ->]|?]; + [apply: find_procedures_of_trace_main|apply: find_procedures_of_trace_exp]. + Qed. + + Definition program_of_trace (t: trace) : program := + {| prog_interface := intf; + prog_procedures := procedures_of_trace t; + prog_buffers := mapm (fun _ => inr [Int 0]) intf |}. + (* old CCS version *) + Section WithTrace. From 362f9d9ce22bb01e434b3f6e9768907cb3bf5efc Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 4 Apr 2023 14:56:13 +0200 Subject: [PATCH 007/174] WIP --- security/Backtranslation.v | 747 ++++++++++++++++++++++--------------- 1 file changed, 437 insertions(+), 310 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 289b483ac3..25b9e2a88c 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -11,29 +11,7 @@ Record backtranslation_environment := Section Backtranslation. - Variable bt_env: backtranslation_environment. - - (** switch statement; use to convert a trace to a code **) - - 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_long Int64.one type_counter in - Sifthenelse (Ebinop Cop.Oeq - (Evar (bt_env.(local_counter) cp) 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)) - 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 @@ -50,305 +28,454 @@ Section Backtranslation. Ltac take_step := econstructor; [econstructor; simpl_expr | | traceEq]; simpl. - Lemma switch_clause_spec p (cp: compartment) f (e: env) le m b (n: int64) (n': Z) s_then s_else: - cp = comp_of f -> - e ! (bt_env.(local_counter) cp) = Some (b, type_counter) -> - 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 + Variable bt_env: backtranslation_environment. + + Section SWITCH. + (** switch statement; use to convert a trace to a code **) + + 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_long Int64.one type_counter in + Sifthenelse (Ebinop Cop.Oeq + (Evar (bt_env.(local_counter) cp) 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)) + s_then) + (* if false *) + s_else. + + 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 p (cp: compartment) f (e: env) le m b (n: int64) (n': Z) s_then s_else: + cp = comp_of f -> + e ! (bt_env.(local_counter) cp) = Some (b, type_counter) -> + 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 Mint64 m (Vptr b Ptrofs.zero) (Vlong (Int64.add n Int64.one)) cp = Some m' /\ + 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') + 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 (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 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. + 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 (e: env) le m b (n: Z) ss s_else + (WF: Z.of_nat (length ss) < Int64.modulus) + (RANGE: Z.of_nat (length ss) <= n < Int64.modulus) + : + cp = comp_of f -> + e ! (bt_env.(local_counter) cp) = Some (b, type_counter) -> + (* Mem.valid_access m Mint64 b 0 Writable (Some cp) -> *) + Mem.loadv Mint64 m (Vptr b Ptrofs.zero) (Some cp) = Some (Vlong (Int64.repr n)) -> + Star (Clight.semantics1 p) + (State f (switch cp ss s_else) Kstop e le m) + E0 + (State f s_else Kstop e le m). + Proof. + intros; subst cp. unfold switch. destruct RANGE as [RA1 RA2]. + assert (G: forall n', + (Z.of_nat (length ss)) <= n' -> + n' <= 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)). + { intros n' LE1 LE2. + induction ss as [|s ss IH]; try apply star_refl. + 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. + - 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. + } + now apply G; lia. + Qed. + + Let nat64 n := Int64.repr (Z.of_nat n). + + Lemma switch_spec + p (cp: compartment) f (e: env) le m b + ss s ss' s_else + (WF: Z.of_nat (length (ss ++ s :: ss')) < Int64.modulus) + : + cp = comp_of f -> + e ! (bt_env.(local_counter) cp) = Some (b, type_counter) -> + 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 n Int64.one)) cp = Some m' /\ - 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') - 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 (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. + Mem.storev Mint64 m (Vptr b Ptrofs.zero) (Vlong (Int64.add (nat64 (length ss)) Int64.one)) cp = Some m' /\ + Star (Clight.semantics1 p) + (State f (switch cp (ss ++ s :: ss') s_else) Kstop e le m) + E0 + (State f s Kstop e le m'). + Proof. + intros. + assert (Eswitch : + exists s_else', + switch cp (ss ++ s :: ss') s_else = + switch cp ss (switch_clause cp (Z.of_nat (length ss)) s s_else')). + { unfold switch. rewrite fold_right_app, app_length. simpl. + exists (snd (fold_right (switch_add_statement cp) (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 p cp f e le m b (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 CODE. + (** converting trace to code **) + + 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. + + 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). + + Lemma ptr_of_id_ofs_eval + id ofs e (ge: genv) b cp le m + (GE1: e ! id = None) + (GE2: Genv.find_symbol ge id = Some b) + : + eval_expr ge e cp le m (ptr_of_id_ofs id ofs) (Vptr b ofs). + Proof. + 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. + + 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. + + Definition wf_eventval (ge: genv) (e: env) (v: eventval): Prop := + match v with + | EVptr_global id _ => (e ! id = None) /\ (Senv.public_symbol ge id = true) + | _ => True + end. + + Lemma eventval_to_expr_match + ge env cp le m + ev exp v ty + (WFEV: wf_eventval ge env ev) + (CONV: eventval_to_expr ev = exp) + (EVAL: eval_expr ge env cp le m exp v) + (TYPE: typ_of_type (eventval_to_type ev) = ty) + : + eventval_match ge ev ty v. + Proof. + subst. destruct ev; simpl in *. + - inversion EVAL; subst; simpl in *; try constructor. inversion H. + - inversion EVAL; subst; simpl in *; try constructor. inversion H. + - inversion EVAL; subst; simpl in *; try constructor. inversion H. + - inversion EVAL; subst; simpl in *; try constructor. inversion H. + - destruct WFEV as [WFEV1 WFEV2]. unfold ptr_of_id_ofs in EVAL. destruct Archi.ptr64 eqn:ARCH. + + inversion EVAL; subst; simpl in *; try constructor. + 2:{ inversion H. } + inversion H5; subst; simpl in *. + 2:{ inversion H. } + clear H5. inversion H4; subst; simpl in *. + 2:{ inversion H. } + clear H4. inversion H2; subst; simpl. + { rewrite WFEV1 in H4. inversion H4. } + { inversion H6. + rewrite Ptrofs.mul_commut, Ptrofs.mul_one. + rewrite Ptrofs.add_zero_l. + replace (Ptrofs.of_int64 (Ptrofs.to_int64 i0)) with i0. + constructor; auto. + symmetry. apply Ptrofs.of_int64_to_int64. auto. + } + + inversion EVAL; subst; simpl in *; try constructor. + 2:{ inversion H. } + inversion H5; subst; simpl in *. + 2:{ inversion H. } + clear H5. inversion H4; subst; simpl in *. + 2:{ inversion H. } + clear H4. inversion H2; subst; simpl. + { rewrite WFEV1 in H4. inversion H4. } + { inversion H6. + rewrite Ptrofs.mul_commut, Ptrofs.mul_one. + rewrite Ptrofs.add_zero_l. + replace (Ptrofs.of_ints (Ptrofs.to_int i0)) with i0. + constructor; auto. + symmetry. apply Ptrofs.agree32_of_ints_eq; auto. + apply Ptrofs.agree32_to_int; auto. + } + Qed. + + + 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 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). + + 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. + + + Lemma code_of_event_step_vload + ev + ch id ofs v + p f k e le m + (WFEV: wf_eventval (globalenv p) e v) + (EV: ev = Event_vload ch id ofs v) + (WFTY: typ_of_type (eventval_to_type v) = type_of_chunk ch) + (GLOB: e ! id = None) + b + (GE: Genv.find_symbol (globalenv p) id = Some b) + (VOL: Senv.block_is_volatile (globalenv p) b = true) + : + (* exists m', *) + Star (Clight.semantics1 p) + (State f (code_of_event ev) k e le m) + (ev :: nil) + (State f Sskip k e le m). + (* (State f Sskip k e le m'). *) + Proof. + subst; simpl in *. unfold code_of_vload. + destruct Archi.ptr64 eqn:ARCH. + - econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_builtin. + { econstructor; eauto. 3: econstructor. + - eapply ptr_of_id_ofs_eval; eauto. + - unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. + } + repeat econstructor; eauto. eapply eventval_to_expr_match; eauto. + admit. + } + econstructor 1. + - econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_builtin. + { econstructor; eauto. 3: econstructor. + - eapply ptr_of_id_ofs_eval; eauto. + - unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. + } + repeat econstructor; eauto. eapply eventval_to_expr_match; eauto. + admit. + } + econstructor 1. + - Definition switch_add_statement cp s res := - (Z.pred (fst res), switch_clause cp (Z.pred (fst res)) s (snd res)). + volatile_load_vol : forall (chunk : memory_chunk) (m : mem) (b : block) (ofs : ptrofs) (id : ident) (ev : eventval) (v : val), + Senv.block_is_volatile ge b = true -> + Senv.find_symbol ge id = Some b -> eventval_match ge ev (type_of_chunk chunk) v -> volatile_load ge cp chunk m b ofs (Event_vload chunk id ofs ev :: nil) (Val.load_result chunk v) + + | step_builtin : forall (f : function) (optid : option ident) (ef : external_function) (tyargs : typelist) (al : list expr) (k : cont) (e : env) (le : temp_env) (m : mem) (vargs : list val) (t : trace) (vres : val) (m' : mem), + eval_exprlist ge e (comp_of f) le m al tyargs vargs -> + external_call ef ge (comp_of f) vargs m t vres m' -> + step ge function_entry (State f (Sbuiltin optid ef tyargs al) k e le m) t (State f Sskip k e (set_opttemp optid vres le) m') - 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). + (* A while(1)-loop with a big switch inside it *) + Definition code_of_trace cp (t: trace): statement := + Swhile (Econst_int Int.one (Tint I32 Signed noattr)) (switch cp (map code_of_event t) (Sreturn None)). - 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. - Proof. - induction ss as [|s' ss IH]; try now rewrite Z.sub_0_r. - simpl; lia. - Qed. + End CODE. - Lemma switch_spec_else - p (cp: compartment) f (e: env) le m b (n: Z) ss s_else - (WF: Z.of_nat (length ss) < Int64.modulus) - (RANGE: Z.of_nat (length ss) <= n < Int64.modulus) - : - cp = comp_of f -> - e ! (bt_env.(local_counter) cp) = Some (b, type_counter) -> - (* Mem.valid_access m Mint64 b 0 Writable (Some cp) -> *) - Mem.loadv Mint64 m (Vptr b Ptrofs.zero) (Some cp) = Some (Vlong (Int64.repr n)) -> - Star (Clight.semantics1 p) - (State f (switch cp ss s_else) Kstop e le m) - E0 - (State f s_else Kstop e le m). - Proof. - intros; subst cp. unfold switch. destruct RANGE as [RA1 RA2]. - assert (G: forall n', - (Z.of_nat (length ss)) <= n' -> - n' <= 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)). - { intros n' LE1 LE2. - induction ss as [|s ss IH]; try apply star_refl. - 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. - - 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. - } - now apply G; lia. - Qed. - Let nat64 n := Int64.repr (Z.of_nat n). - - Lemma switch_spec - p (cp: compartment) f (e: env) le m b - ss s ss' s_else - (WF: Z.of_nat (length (ss ++ s :: ss')) < Int64.modulus) - : - cp = comp_of f -> - e ! (bt_env.(local_counter) cp) = Some (b, type_counter) -> - 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 (Clight.semantics1 p) - (State f (switch cp (ss ++ s :: ss') s_else) Kstop e le m) - E0 - (State f s Kstop e le m'). - Proof. - intros. - assert (Eswitch : - exists s_else', - switch cp (ss ++ s :: ss') s_else = - switch cp ss (switch_clause cp (Z.of_nat (length ss)) s s_else')). - { unfold switch. rewrite fold_right_app, app_length. simpl. - exists (snd (fold_right (switch_add_statement cp) (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 p cp f e le m b (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. + Section PROJ. + (** Projection of the trace according to compartments **) - (** converting trace to code **) - - 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. - - 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). - - 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. - - Definition wf_eventval (ge: genv) (e: env) (v: eventval): Prop := - match v with - | EVptr_global id _ => (e ! id = None) /\ (Senv.public_symbol ge id = true) - | _ => True - end. - - Lemma eventval_to_expr_inv - ge env cp le m - ev exp v ty - (WFEV: wf_eventval ge env ev) - (CONV: eventval_to_expr ev = exp) - (EVAL: eval_expr ge env cp le m exp v) - (TYPE: typ_of_type (eventval_to_type ev) = ty) - : - eventval_match ge ev ty v. - Proof. - subst. destruct ev; simpl in *. - - inversion EVAL; subst; simpl in *; try constructor. inversion H. - - inversion EVAL; subst; simpl in *; try constructor. inversion H. - - inversion EVAL; subst; simpl in *; try constructor. inversion H. - - inversion EVAL; subst; simpl in *; try constructor. inversion H. - - destruct WFEV as [WFEV1 WFEV2]. unfold ptr_of_id_ofs in EVAL. destruct Archi.ptr64 eqn:ARCH. - + inversion EVAL; subst; simpl in *; try constructor. - 2:{ inversion H. } - inversion H5; subst; simpl in *. - 2:{ inversion H. } - clear H5. inversion H4; subst; simpl in *. - 2:{ inversion H. } - clear H4. inversion H2; subst; simpl. - { rewrite WFEV1 in H4. inversion H4. } - { inversion H6. - rewrite Ptrofs.mul_commut, Ptrofs.mul_one. - rewrite Ptrofs.add_zero_l. - replace (Ptrofs.of_int64 (Ptrofs.to_int64 i0)) with i0. - constructor; auto. - symmetry. apply Ptrofs.of_int64_to_int64. auto. - } - + inversion EVAL; subst; simpl in *; try constructor. - 2:{ inversion H. } - inversion H5; subst; simpl in *. - 2:{ inversion H. } - clear H5. inversion H4; subst; simpl in *. - 2:{ inversion H. } - clear H4. inversion H2; subst; simpl. - { rewrite WFEV1 in H4. inversion H4. } - { inversion H6. - rewrite Ptrofs.mul_commut, Ptrofs.mul_one. - rewrite Ptrofs.add_zero_l. - replace (Ptrofs.of_ints (Ptrofs.to_int i0)) with i0. - constructor; auto. - symmetry. apply Ptrofs.agree32_of_ints_eq; auto. - apply Ptrofs.agree32_to_int; auto. - } - Qed. + (* Definition curr_comp_of_event (e: event): option compartment := *) + (* match e with *) + (* | Event_call cp cp' id vs => Some cp *) + (* | Event_return cp cp' v => Some cp' *) + (* | _ => None *) + (* end. *) + + (* Definition next_comp_of_event (e: event): option compartment := *) + (* match e with *) + (* | Event_call cp cp' id vs => Some cp' *) + (* | Event_return cp cp' v => Some cp *) + (* | _ => None *) + (* end. *) + + Definition comp_of_event (e: event): option (compartment * compartment) := + match e with + | Event_call cp cp' id vs => Some (cp, cp') + | Event_return cp cp' v => Some (cp', cp) + | _ => None + end. + + (* Instance has_comp_event: has_comp event := *) + + Definition comp_proj_trace (cp: compartment) (t: trace): compartment * trace := + fold_right + (fun ev '(cp_now, sub) => match comp_of_event ev with + | Some (cp_curr, cp_next) => (cp_next, if (Pos.eqb cp_curr cp) then (ev :: sub) else sub) + | None => (cp_now, if (Pos.eqb cp_now cp) then (ev :: sub) else sub) + end) + (default_compartment, nil) t. + + Definition comp_subtrace (cp: compartment) (t: trace) := + snd (comp_proj_trace cp t). + + Definition code_of_subtrace cp t := + code_of_trace cp (comp_subtrace cp t). + + Definition codes_of_subtraces (cps: list compartment) t : PTree.t statement := + PTree_Properties.of_list (map (fun cp => (cp, code_of_subtrace cp t)) cps). + + Definition get_cps_from_policy (p: Policy.t): list compartment := + map fst (PTree.elements p.(Policy.policy_export)). + + End PROJ. - 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 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). - - 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. - - (* A while(1)-loop with a big switch inside it *) - Definition code_of_trace cp (t: trace): statement := - Swhile (Econst_int Int.one (Tint I32 Signed noattr)) (switch cp (map code_of_event t) (Sreturn None)). - - (** Projection of the trace according to compartments **) - - (* Definition curr_comp_of_event (e: event): option compartment := *) - (* match e with *) - (* | Event_call cp cp' id vs => Some cp *) - (* | Event_return cp cp' v => Some cp' *) - (* | _ => None *) - (* end. *) - - (* Definition next_comp_of_event (e: event): option compartment := *) - (* match e with *) - (* | Event_call cp cp' id vs => Some cp' *) - (* | Event_return cp cp' v => Some cp *) - (* | _ => None *) - (* end. *) - - Definition comp_of_event (e: event): option (compartment * compartment) := - match e with - | Event_call cp cp' id vs => Some (cp, cp') - | Event_return cp cp' v => Some (cp', cp) - | _ => None - end. - - (* Instance has_comp_event: has_comp event := *) - - Definition comp_proj_trace (cp: compartment) (t: trace): compartment * trace := - fold_right - (fun ev '(cp_now, sub) => match comp_of_event ev with - | Some (cp_curr, cp_next) => (cp_next, if (Pos.eqb cp_curr cp) then (ev :: sub) else sub) - | None => (cp_now, if (Pos.eqb cp_now cp) then (ev :: sub) else sub) - end) - (default_compartment, nil) t. - - Definition comp_subtrace (cp: compartment) (t: trace) := - snd (comp_proj_trace cp t). - - Definition code_of_subtrace cp t := - code_of_trace cp (comp_subtrace cp t). (* TODO *) + (* Axiom backtranslation: Policy.t -> split -> trace -> Clight.program * Clight.program. *) + (* Axiom backtranslation_correct: *) + (* forall pol s t p C, *) + (* backtranslation pol s t = (p, C) -> *) + (* clight_compatible s p C /\ *) + (* exists W, link p C = Some W /\ *) + (* clight_program_has_initial_trace W t. *) + + (* Definition clight_has_side (s: split) (lr: side) (p: Clight.program) := *) + (* List.Forall (fun '(id, gd) => *) + (* match gd with *) + (* | Gfun (Ctypes.Internal f) => s (comp_of f) = lr *) + (* | _ => True *) + (* end) *) + (* (Ctypes.prog_defs p). *) + + (* Definition clight_compatible (s: split) (p p': Clight.program) := *) + (* clight_has_side s Left p /\ clight_has_side s Right p'. *) + + (* Definition clight_program_has_initial_trace (p: Clight.program) (t: trace): Prop := *) + (* forall beh, program_behaves (Clight.semantics1 p) beh -> behavior_prefix t beh. *) + + (* 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. *) + + (* Clight.program = Ctypes.program Clight.function *) (* old CCS version *) Lemma comp_subtrace_app (C: Component.id) (t1 t2: trace) : comp_subtrace C (t1 ++ t2) = comp_subtrace C t1 ++ comp_subtrace C t2. Proof. apply: filter_cat. Qed. + Definition procedure_of_trace C P t := + expr_of_trace C P (comp_subtrace C t). + Definition procedures_of_trace (t: trace) : NMap (NMap expr) := mapim (fun C Ciface => let procs := @@ -418,20 +545,20 @@ Section Backtranslation. End Backtranslation. - (* Axiom backtranslation: Policy.t -> split -> trace -> Csyntax.program * Csyntax.program. *) + (* Axiom backtranslation: Policy.t -> split -> trace -> Clight.program * Clight.program. *) (* Axiom backtranslation_correct: *) (* forall pol s t p C, *) (* backtranslation pol s t = (p, C) -> *) - (* c_compatible s p C /\ *) + (* clight_compatible s p C /\ *) (* exists W, link p C = Some W /\ *) - (* c_program_has_initial_trace W t. *) + (* clight_program_has_initial_trace W t. *) (* 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. *) + (* transf_clight_program p = OK p_compiled /\ *) + (* transf_clight_program C = OK C_compiled. *) (* Axiom backtranslation_pol: forall pol s t, *) (* Ctypes.prog_pol (fst (backtranslation pol s t)) = pol /\ *) From 2cabda229952ecf11dd50a455a4ba130694210a8 Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 4 Apr 2023 18:39:12 +0200 Subject: [PATCH 008/174] WIP --- security/Backtranslation.v | 178 +++++++++++++++++++++++++++++++------ 1 file changed, 153 insertions(+), 25 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 25b9e2a88c..480c823f69 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -221,6 +221,12 @@ Section Backtranslation. erewrite Ptrofs.agree32_of_ints_eq; auto. apply Ptrofs.agree32_to_int; auto. Qed. + 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. + Definition eventval_to_expr (v: eventval): expr := match v with | EVint i => Econst_int i (Tint I32 Signed noattr) @@ -236,6 +242,30 @@ Section Backtranslation. | _ => True end. + Definition wf_eventval_weak (ge: genv) (e: env) (v: eventval): Prop := + match v with + | EVptr_global id _ => (e ! id = None) /\ (exists b, Genv.find_symbol ge id = Some b) + | _ => True + end. + + Lemma wf_eventval_weak_weak + ge e v + : + wf_eventval ge e v -> wf_eventval_weak ge e v. + Proof. intros H. destruct v; simpl in *; auto. destruct H. split; auto. apply Genv.public_symbol_exists in H0. auto. Qed. + + Definition wf_eventval_weak2 (ge: genv) (v: eventval): Prop := + match v with + | EVptr_global id _ => (exists b, Genv.find_symbol ge id = Some b) + | _ => True + end. + + Lemma wf_eventval_weak2_weak + ge e v + : + wf_eventval_weak ge e v -> wf_eventval_weak2 ge v. + Proof. intros H. destruct v; simpl in *; auto. destruct H. auto. Qed. + Lemma eventval_to_expr_match ge env cp le m ev exp v ty @@ -285,7 +315,64 @@ Section Backtranslation. } Qed. + Definition eventval_to_val (ge: genv) (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. + Lemma eventval_to_expr_val_eval + ge en cp temp m ev + (WF: wf_eventval_weak ge en ev) + : + eval_expr ge en cp temp m (eventval_to_expr ev) (eventval_to_val ge ev). + Proof. + destruct ev; simpl in *; try constructor. + destruct WF as [WF0 [b WF1]]. + rewrite WF1. unfold ptr_of_id_ofs. destruct Archi.ptr64 eqn:ARCH. + - econstructor; try econstructor. eapply eval_Evar_global; eauto. + simpl. simpl_expr. rewrite Ptrofs.mul_commut, Ptrofs.mul_one. rewrite Ptrofs.add_zero_l. + rewrite Ptrofs.of_int64_to_int64; auto. + - econstructor; try econstructor. eapply eval_Evar_global; eauto. + 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 eventval_to_expr_val_match + ge env + ev exp v ty + (WFEV: wf_eventval ge env ev) + (CONV0: eventval_to_expr ev = exp) + (CONV1: eventval_to_val ge ev = v) + (TYPE: typ_of_type (eventval_to_type ev) = ty) + : + eventval_match ge ev ty v. + Proof. + subst. eapply eventval_to_expr_match; eauto. eapply eventval_to_expr_val_eval; eauto. apply wf_eventval_weak_weak; auto. + Unshelve. exact default_compartment. exact (PTree.empty val). exact Mem.empty. + Qed. + + 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. + + Lemma sem_cast_eventval + ge v m + (WFEV: wf_eventval_weak2 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. + + + (* converting functions *) Fixpoint list_eventval_to_typelist (vs: list eventval): typelist := match vs with | nil => Tnil @@ -295,14 +382,12 @@ Section Backtranslation. 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). + Sbuiltin None (EF_vstore ch) (Tcons (Tpointer Tvoid noattr) (Tcons (eventval_to_type v) Tnil)) ((ptr_of_id_ofs id ofs) :: (eventval_to_expr v) :: nil). Definition code_of_annot (str: string) (vs: list eventval) := Sbuiltin None (EF_annot @@ -315,38 +400,44 @@ Section Backtranslation. 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). + (* 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_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_syscall name vs v => code_of_syscall name vs v | Event_return cp cp' v => code_of_return cp cp' v end. + (* A while(1)-loop with a big switch inside it *) + Definition code_of_trace cp (t: trace): statement := + Swhile (Econst_int Int.one (Tint I32 Signed noattr)) (switch cp (map code_of_event t) (Sreturn None)). + + (* Properties *) Lemma code_of_event_step_vload ev ch id ofs v p f k e le m - (WFEV: wf_eventval (globalenv p) e v) (EV: ev = Event_vload ch id ofs v) - (WFTY: typ_of_type (eventval_to_type v) = type_of_chunk ch) (GLOB: e ! id = None) b - (GE: Genv.find_symbol (globalenv p) id = Some b) (VOL: Senv.block_is_volatile (globalenv p) b = true) + (GE: Genv.find_symbol (globalenv p) id = Some b) + rv + (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) rv) : - (* exists m', *) Star (Clight.semantics1 p) (State f (code_of_event ev) k e le m) (ev :: nil) (State f Sskip k e le m). - (* (State f Sskip k e le m'). *) Proof. subst; simpl in *. unfold code_of_vload. destruct Archi.ptr64 eqn:ARCH. @@ -357,8 +448,7 @@ Section Backtranslation. - eapply ptr_of_id_ofs_eval; eauto. - unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. } - repeat econstructor; eauto. eapply eventval_to_expr_match; eauto. - admit. + repeat econstructor; eauto. } econstructor 1. - econstructor 2. @@ -368,24 +458,62 @@ Section Backtranslation. - eapply ptr_of_id_ofs_eval; eauto. - unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. } - repeat econstructor; eauto. eapply eventval_to_expr_match; eauto. - admit. + repeat econstructor; eauto. } econstructor 1. - + Qed. - volatile_load_vol : forall (chunk : memory_chunk) (m : mem) (b : block) (ofs : ptrofs) (id : ident) (ev : eventval) (v : val), - Senv.block_is_volatile ge b = true -> - Senv.find_symbol ge id = Some b -> eventval_match ge ev (type_of_chunk chunk) v -> volatile_load ge cp chunk m b ofs (Event_vload chunk id ofs ev :: nil) (Val.load_result chunk v) - - | step_builtin : forall (f : function) (optid : option ident) (ef : external_function) (tyargs : typelist) (al : list expr) (k : cont) (e : env) (le : temp_env) (m : mem) (vargs : list val) (t : trace) (vres : val) (m' : mem), - eval_exprlist ge e (comp_of f) le m al tyargs vargs -> - external_call ef ge (comp_of f) vargs m t vres m' -> - step ge function_entry (State f (Sbuiltin optid ef tyargs al) k e le m) t (State f Sskip k e (set_opttemp optid vres le) m') + Lemma code_of_event_step_vstore + ev + ch id ofs v + p f k e le m + (EV: ev = Event_vstore ch id ofs v) + (GLOB: e ! id = None) + b + (VOL: Senv.block_is_volatile (globalenv p) b = true) + (GE: Genv.find_symbol (globalenv p) id = Some b) + (WFSV: wf_eventval_weak (globalenv p) e v) + (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) (Val.load_result ch (eventval_to_val (globalenv p) v))) + : + Star (Clight.semantics1 p) + (State f (code_of_event ev) k e le m) + (ev :: nil) + (State f Sskip k e le m). + Proof. + subst; simpl in *. unfold code_of_vstore. + destruct Archi.ptr64 eqn:ARCH. + - econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_builtin. + { econstructor; eauto. + { eapply ptr_of_id_ofs_eval; eauto. } + { unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. } + econstructor; eauto. 3: econstructor. + { eapply eventval_to_expr_val_eval. auto. } + { apply sem_cast_eventval. eapply wf_eventval_weak2_weak; eauto. } + } + simpl. + repeat econstructor; eauto. + } + econstructor 1. + - econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_builtin. + { econstructor; eauto. + { eapply ptr_of_id_ofs_eval; eauto. } + { unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. } + econstructor; eauto. 3: econstructor. + { eapply eventval_to_expr_val_eval. auto. } + { apply sem_cast_eventval. eapply wf_eventval_weak2_weak; eauto. } + } + simpl. + repeat econstructor; eauto. + } + econstructor 1. + Qed. + + (* TODO *) - (* A while(1)-loop with a big switch inside it *) - Definition code_of_trace cp (t: trace): statement := - Swhile (Econst_int Int.one (Tint I32 Signed noattr)) (switch cp (map code_of_event t) (Sreturn None)). End CODE. From cd10e4a5b2317653e59b5795c82fa89f1004f3a6 Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 5 Apr 2023 15:46:39 +0200 Subject: [PATCH 009/174] WIP --- security/Backtranslation.v | 73 +++++++++++++++++++++++++++++++++----- 1 file changed, 64 insertions(+), 9 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 480c823f69..d662a59d36 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -327,6 +327,18 @@ Section Backtranslation. end 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 list_eventval_to_list_expr (vs: list eventval): list expr := + List.map eventval_to_expr vs. + + Definition list_eventval_to_list_val (ge: genv) (vs: list eventval): list val := + List.map (eventval_to_val ge) vs. + Lemma eventval_to_expr_val_eval ge en cp temp m ev (WF: wf_eventval_weak ge en ev) @@ -371,18 +383,33 @@ Section Backtranslation. 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_eval + ge en cp temp m evs + (WF: Forall (wf_eventval_weak ge en) 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 WF. induction evs; intros; simpl in *. constructor. + inversion WF; clear WF; subst. econstructor; eauto. eapply eventval_to_expr_val_eval; eauto. + apply sem_cast_eventval. eapply wf_eventval_weak2_weak; eauto. + Qed. - (* converting functions *) - 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 list_eventval_to_list_expr (vs: list eventval): list expr := - List.map eventval_to_expr vs. + Lemma list_eventval_to_expr_val_match + ge env + evs exps vs tys + (WFEV: Forall (wf_eventval ge env) evs) + (CONV0: list_eventval_to_list_expr evs = exps) + (CONV1: list_eventval_to_list_val ge evs = vs) + (TYPE: list_eventval_to_typelist evs = tys) + : + eventval_list_match ge evs (typlist_of_typelist tys) vs. + Proof. + move evs at top. revert ge env exps vs tys WFEV CONV0 CONV1 TYPE. induction evs; intros; simpl in *; subst. constructor. + inversion WFEV; clear WFEV; subst. econstructor; eauto. eapply eventval_to_expr_val_match; eauto. + Qed. + (* converting functions *) 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). @@ -427,10 +454,12 @@ Section Backtranslation. ch id ofs v p f k e le m (EV: ev = Event_vload ch id ofs v) + (* bt should ensure them *) (GLOB: e ! id = None) b (VOL: Senv.block_is_volatile (globalenv p) b = true) (GE: Genv.find_symbol (globalenv p) id = Some b) + (* asm should ensure them *) rv (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) rv) : @@ -468,10 +497,12 @@ Section Backtranslation. ch id ofs v p f k e le m (EV: ev = Event_vstore ch id ofs v) + (* bt should ensure them *) (GLOB: e ! id = None) b (VOL: Senv.block_is_volatile (globalenv p) b = true) (GE: Genv.find_symbol (globalenv p) id = Some b) + (* asm should ensure them *) (WFSV: wf_eventval_weak (globalenv p) e v) (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) (Val.load_result ch (eventval_to_val (globalenv p) v))) : @@ -512,6 +543,30 @@ Section Backtranslation. econstructor 1. Qed. + Lemma code_of_event_step_annot + ev + str vs + p f k e le m + (EV: ev = Event_annot str vs) + (* bt should ensure them *) + (WF: Forall (wf_eventval (globalenv p) e) vs) + (* asm should ensure them *) + : + Star (Clight.semantics1 p) + (State f (code_of_event ev) k e le m) + (ev :: nil) + (State f Sskip k e le m). + Proof. + subst; simpl in *. unfold code_of_annot. + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_builtin. + { eapply list_eventval_to_expr_val_eval. eapply Forall_impl. 2: eauto. intros. apply wf_eventval_weak_weak; auto. } + repeat econstructor; eauto. eapply list_eventval_to_expr_val_match; eauto. + } + econstructor 1. + Qed. + (* TODO *) From bcac812993ceb25d3afb5e1599cd348cdc17be6b Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 6 Apr 2023 15:00:29 +0200 Subject: [PATCH 010/174] WIP --- security/Backtranslation.v | 126 +++++++++++++++++++++++++++++++++++++ 1 file changed, 126 insertions(+) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index d662a59d36..51c3c33fe2 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -567,8 +567,134 @@ Section Backtranslation. econstructor 1. Qed. + Lemma code_of_event_step_call_internal + ev + cp cp' id vs + p f k e le m + ge + (GE: ge = globalenv p) + (EV: ev = Event_call cp cp' id vs) + (* bt should ensure them *) + (GLOB: e ! id = None) + b + (FINDB: Genv.find_symbol ge id = Some b) + fd + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (TYPEF: type_of_fundef fd = Tfunction (list_eventval_to_typelist vs) Tvoid cc_default) + (WFARGS: Forall (wf_eventval ge e) vs) + f1 + (INTERNAL: fd = Internal f1) + (* asm should ensure them *) + (NPTR: Forall not_ptr (list_eventval_to_list_val ge vs)) + (CP1: cp = comp_of f) + (CP2: cp' = comp_of fd) + (CROSS: Genv.type_of_call ge (comp_of f) (comp_of fd) = Genv.CrossCompartmentCall) + (ALLOW: Genv.allowed_cross_call ge (comp_of f) (Vptr b Ptrofs.zero)) + (* handle during proof *) + e1 le1 m1 + (ENTRY: function_entry1 ge f1 (list_eventval_to_list_val ge vs) m e1 le1 m1) + : + Star (Clight.semantics1 p) + (State f (code_of_event ev) k e le m) + (ev :: nil) + (State f1 (fn_body f1) (Kcall None f e le k) e1 le1 m1). + Proof. + subst; simpl. unfold code_of_call. + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_call; simpl; eauto. + { eapply eval_Elvalue. + - eapply eval_Evar_global; eauto. + - eapply deref_loc_reference. auto. + } + { eapply list_eventval_to_expr_val_eval. eapply Forall_impl. 2: eauto. intros. apply wf_eventval_weak_weak; auto. } + red; auto. + unfold Genv.find_comp. setoid_rewrite FINDF. + eapply call_trace_cross; eauto. apply Genv.find_invert_symbol; auto. + eapply (list_eventval_to_expr_val_match (globalenv p)); eauto. + } + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_internal_function; eauto. } + econstructor 1. + Qed. + + Lemma code_of_event_step_call_external + ev + cp cp' id vs + p f k e le m + ge + (GE: ge = globalenv p) + (EV: ev = Event_call cp cp' id vs) + (* bt should ensure them *) + (GLOB: e ! id = None) + b + (FINDB: Genv.find_symbol ge id = Some b) + fd + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (TYPEF: type_of_fundef fd = Tfunction (list_eventval_to_typelist vs) Tvoid cc_default) + (WFARGS: Forall (wf_eventval ge e) vs) + ef0 targs0 tres0 cconv0 + (EXTERNAL: fd = External ef0 targs0 tres0 cconv0) + (* asm should ensure them *) + (NPTR: Forall not_ptr (list_eventval_to_list_val ge vs)) + (CP1: cp = comp_of f) + (CP2: cp' = comp_of fd) + (CROSS: Genv.type_of_call ge (comp_of f) (comp_of fd) = Genv.CrossCompartmentCall) + (ALLOW: Genv.allowed_cross_call ge (comp_of f) (Vptr b Ptrofs.zero)) + (* handle during proof *) + sev sname sargs svr + (SYSEV: sev = Event_syscall sname sargs svr) + vres m1 + (SEM: external_call ef0 ge (comp_of f) (list_eventval_to_list_val ge vs) m (sev :: nil) vres m1) + : + Star (Clight.semantics1 p) + (State f (code_of_event ev) k e le m) + (ev :: sev :: nil) + (Returnstate vres (Kcall None f e le k) m1 (rettype_of_type tres0) (comp_of ef0)). + Proof. + subst; simpl. unfold code_of_call. + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_call; simpl; eauto. + { eapply eval_Elvalue. + - eapply eval_Evar_global; eauto. + - eapply deref_loc_reference. auto. + } + { eapply list_eventval_to_expr_val_eval. eapply Forall_impl. 2: eauto. intros. apply wf_eventval_weak_weak; auto. } + red; auto. + unfold Genv.find_comp. setoid_rewrite FINDF. + eapply call_trace_cross; eauto. apply Genv.find_invert_symbol; auto. + eapply (list_eventval_to_expr_val_match (globalenv p)); eauto. + } + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_internal_function; eauto. } + econstructor 1. + Qed. + (* TODO *) + | step_call : forall (f : function) (optid : option ident) (a : expr) (al : list expr) (k : cont) (e : env) (le : temp_env) (m : mem) (tyargs : typelist) (tyres : type) (cconv : calling_convention) + (vf : val) (vargs : list val) (fd : fundef) (t : trace), + Cop.classify_fun (typeof a) = Cop.fun_case_f tyargs tyres cconv -> + eval_expr ge e (comp_of f) le m a vf -> + eval_exprlist ge e (comp_of f) le m al tyargs vargs -> + Genv.find_funct ge vf = Some fd -> + type_of_fundef fd = Tfunction tyargs tyres cconv -> + Genv.allowed_call ge (comp_of f) vf -> + (Genv.type_of_call ge (comp_of f) (Genv.find_comp ge vf) = Genv.CrossCompartmentCall -> Forall not_ptr vargs) -> + call_trace ge (comp_of f) (Genv.find_comp ge vf) vf vargs (typlist_of_typelist tyargs) t -> + step ge function_entry (State f (Scall optid a al) k e le m) t (Callstate fd vargs (Kcall optid f e le k) m) + + 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). + + match e with + | Event_syscall name vs v => code_of_syscall name vs v + | Event_return cp cp' v => code_of_return cp cp' v + end. + End CODE. From f28df8a9806aad53bbc14b75e053ed421660c12b Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 6 Apr 2023 20:16:15 +0200 Subject: [PATCH 011/174] WIP --- security/Backtranslation.v | 91 ++++++++++++++------------------------ 1 file changed, 32 insertions(+), 59 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 51c3c33fe2..7ba48bee54 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -567,7 +567,7 @@ Section Backtranslation. econstructor 1. Qed. - Lemma code_of_event_step_call_internal + Lemma code_of_event_step_call_start ev cp cp' id vs p f k e le m @@ -582,22 +582,17 @@ Section Backtranslation. (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) (TYPEF: type_of_fundef fd = Tfunction (list_eventval_to_typelist vs) Tvoid cc_default) (WFARGS: Forall (wf_eventval ge e) vs) - f1 - (INTERNAL: fd = Internal f1) (* asm should ensure them *) (NPTR: Forall not_ptr (list_eventval_to_list_val ge vs)) (CP1: cp = comp_of f) (CP2: cp' = comp_of fd) (CROSS: Genv.type_of_call ge (comp_of f) (comp_of fd) = Genv.CrossCompartmentCall) (ALLOW: Genv.allowed_cross_call ge (comp_of f) (Vptr b Ptrofs.zero)) - (* handle during proof *) - e1 le1 m1 - (ENTRY: function_entry1 ge f1 (list_eventval_to_list_val ge vs) m e1 le1 m1) : Star (Clight.semantics1 p) (State f (code_of_event ev) k e le m) (ev :: nil) - (State f1 (fn_body f1) (Kcall None f e le k) e1 le1 m1). + (Callstate fd (list_eventval_to_list_val ge vs) (Kcall None f e le k) m). Proof. subst; simpl. unfold code_of_call. econstructor 2. @@ -613,6 +608,27 @@ Section Backtranslation. eapply call_trace_cross; eauto. apply Genv.find_invert_symbol; auto. eapply (list_eventval_to_expr_val_match (globalenv p)); eauto. } + econstructor 1. + Qed. + + Lemma code_of_event_step_call_internal + p f k e le m + ge + (GE: ge = globalenv p) + (* bt should ensure them *) + fd args f1 + (INTERNAL: fd = Internal f1) + (* asm should ensure them *) + (* handle during proof *) + e1 le1 m1 + (ENTRY: function_entry1 ge f1 args m e1 le1 m1) + : + Star (Clight.semantics1 p) + (Callstate fd args (Kcall None f e le k) m) + nil + (State f1 (fn_body f1) (Kcall None f e le k) e1 le1 m1). + Proof. + subst; simpl. econstructor 2. 3:{ rewrite E0_right. reflexivity. } { eapply step_internal_function; eauto. } @@ -620,78 +636,35 @@ Section Backtranslation. Qed. Lemma code_of_event_step_call_external - ev - cp cp' id vs - p f k e le m + p m ge (GE: ge = globalenv p) - (EV: ev = Event_call cp cp' id vs) (* bt should ensure them *) - (GLOB: e ! id = None) - b - (FINDB: Genv.find_symbol ge id = Some b) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (TYPEF: type_of_fundef fd = Tfunction (list_eventval_to_typelist vs) Tvoid cc_default) - (WFARGS: Forall (wf_eventval ge e) vs) - ef0 targs0 tres0 cconv0 - (EXTERNAL: fd = External ef0 targs0 tres0 cconv0) + fd k args ef targs tres cconv + (EXTERNAL: fd = External ef targs tres cconv) (* asm should ensure them *) - (NPTR: Forall not_ptr (list_eventval_to_list_val ge vs)) - (CP1: cp = comp_of f) - (CP2: cp' = comp_of fd) - (CROSS: Genv.type_of_call ge (comp_of f) (comp_of fd) = Genv.CrossCompartmentCall) - (ALLOW: Genv.allowed_cross_call ge (comp_of f) (Vptr b Ptrofs.zero)) (* handle during proof *) sev sname sargs svr (SYSEV: sev = Event_syscall sname sargs svr) vres m1 - (SEM: external_call ef0 ge (comp_of f) (list_eventval_to_list_val ge vs) m (sev :: nil) vres m1) + (SEM: external_call ef ge (call_comp k) args m (sev :: nil) vres m1) : Star (Clight.semantics1 p) - (State f (code_of_event ev) k e le m) - (ev :: sev :: nil) - (Returnstate vres (Kcall None f e le k) m1 (rettype_of_type tres0) (comp_of ef0)). + (Callstate fd args k m) + (sev :: nil) + (Returnstate vres k m1 (rettype_of_type tres) (comp_of ef)). Proof. - subst; simpl. unfold code_of_call. - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_call; simpl; eauto. - { eapply eval_Elvalue. - - eapply eval_Evar_global; eauto. - - eapply deref_loc_reference. auto. - } - { eapply list_eventval_to_expr_val_eval. eapply Forall_impl. 2: eauto. intros. apply wf_eventval_weak_weak; auto. } - red; auto. - unfold Genv.find_comp. setoid_rewrite FINDF. - eapply call_trace_cross; eauto. apply Genv.find_invert_symbol; auto. - eapply (list_eventval_to_expr_val_match (globalenv p)); eauto. - } + subst; simpl. econstructor 2. 3:{ rewrite E0_right. reflexivity. } - { eapply step_internal_function; eauto. } + { eapply step_external_function; eauto. } econstructor 1. Qed. (* TODO *) - | step_call : forall (f : function) (optid : option ident) (a : expr) (al : list expr) (k : cont) (e : env) (le : temp_env) (m : mem) (tyargs : typelist) (tyres : type) (cconv : calling_convention) - (vf : val) (vargs : list val) (fd : fundef) (t : trace), - Cop.classify_fun (typeof a) = Cop.fun_case_f tyargs tyres cconv -> - eval_expr ge e (comp_of f) le m a vf -> - eval_exprlist ge e (comp_of f) le m al tyargs vargs -> - Genv.find_funct ge vf = Some fd -> - type_of_fundef fd = Tfunction tyargs tyres cconv -> - Genv.allowed_call ge (comp_of f) vf -> - (Genv.type_of_call ge (comp_of f) (Genv.find_comp ge vf) = Genv.CrossCompartmentCall -> Forall not_ptr vargs) -> - call_trace ge (comp_of f) (Genv.find_comp ge vf) vf vargs (typlist_of_typelist tyargs) t -> - step ge function_entry (State f (Scall optid a al) k e le m) t (Callstate fd vargs (Kcall optid f e le k) m) - - 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). match e with - | Event_syscall name vs v => code_of_syscall name vs v | Event_return cp cp' v => code_of_return cp cp' v end. From 7daf49ed4c23cf8b3c1afdf77c444727f1d6653a Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 12 Apr 2023 13:03:13 +0200 Subject: [PATCH 012/174] backtranslation: proved step lemmas --- security/Backtranslation.v | 60 +++++++++++++++++++++++++++++++------- 1 file changed, 49 insertions(+), 11 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 7ba48bee54..ad9c1c97b6 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -583,9 +583,9 @@ Section Backtranslation. (TYPEF: type_of_fundef fd = Tfunction (list_eventval_to_typelist vs) Tvoid cc_default) (WFARGS: Forall (wf_eventval ge e) vs) (* asm should ensure them *) - (NPTR: Forall not_ptr (list_eventval_to_list_val ge vs)) (CP1: cp = comp_of f) (CP2: cp' = comp_of fd) + (NPTR: Forall not_ptr (list_eventval_to_list_val ge vs)) (CROSS: Genv.type_of_call ge (comp_of f) (comp_of fd) = Genv.CrossCompartmentCall) (ALLOW: Genv.allowed_cross_call ge (comp_of f) (Vptr b Ptrofs.zero)) : @@ -619,7 +619,7 @@ Section Backtranslation. fd args f1 (INTERNAL: fd = Internal f1) (* asm should ensure them *) - (* handle during proof *) + (* handle during proving *) e1 le1 m1 (ENTRY: function_entry1 ge f1 args m e1 le1 m1) : @@ -643,11 +643,12 @@ Section Backtranslation. fd k args ef targs tres cconv (EXTERNAL: fd = External ef targs tres cconv) (* asm should ensure them *) - (* handle during proof *) - sev sname sargs svr - (SYSEV: sev = Event_syscall sname sargs svr) + sev vres m1 (SEM: external_call ef ge (call_comp k) args m (sev :: nil) vres m1) + (* handle during proving *) + sname sargs svr + (SYSEV: sev = Event_syscall sname sargs svr) : Star (Clight.semantics1 p) (Callstate fd args k m) @@ -661,13 +662,50 @@ Section Backtranslation. econstructor 1. Qed. - (* TODO *) - - - match e with - | Event_return cp cp' v => code_of_return cp cp' v - end. + Lemma code_of_event_step_return + ev + cp cp' rv + p f k e le m + ge + (GE: ge = globalenv p) + (EV: ev = Event_return cp' cp rv) + (* bt should ensure them *) + (WFRV: wf_eventval ge e rv) + (RTTYP: fn_return f = eventval_to_type rv) + (* asm should ensure them *) + optid f' e' le' k' + (CONT: call_cont k = Kcall optid f' e' le' k') + (CP1: cp = comp_of f) + (CP2: cp' = comp_of f') + (NPTR: not_ptr (eventval_to_val ge rv)) + (CROSS: Genv.type_of_call ge (comp_of f') (comp_of f) = Genv.CrossCompartmentCall) + (* handle during proving *) + m' + (FREE: Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m') + : + Star (Clight.semantics1 p) + (State f (code_of_event ev) k e le m) + (ev :: nil) + (State f' Sskip k' e' (set_opttemp optid (eventval_to_val ge rv) le') m'). + Proof. + subst; simpl. unfold code_of_return. + econstructor 2. + 3:{ rewrite E0_left. reflexivity. } + { eapply step_return_1; simpl; eauto. + { eapply eventval_to_expr_val_eval; auto. apply wf_eventval_weak_weak; auto. } + { rewrite RTTYP. eapply sem_cast_eventval. + eapply wf_eventval_weak2_weak. eapply wf_eventval_weak_weak; eauto. } + } + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { rewrite CONT. eapply step_returnstate; auto. + econstructor 2; auto. rewrite RTTYP. eapply eventval_to_expr_val_match; eauto. + clear. destruct rv; simpl; auto. + } + econstructor 1. + Qed. + (* TODO *) End CODE. From 4ab80d86ba914f0ae28bd0778e86a715a728d212 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 13 Apr 2023 17:00:28 +0200 Subject: [PATCH 013/174] WIP --- security/Backtranslation.v | 404 +++++++++++++++++++++++++++++++------ 1 file changed, 339 insertions(+), 65 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index ad9c1c97b6..7f7a8a5992 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -181,6 +181,8 @@ Section Backtranslation. Section CODE. (** converting trace to code **) + Definition wf_env (e: env) id := e ! id = None. + Definition eventval_to_type (v: eventval): type := match v with | EVint _ => Tint I32 Signed noattr @@ -205,7 +207,7 @@ Section Backtranslation. Lemma ptr_of_id_ofs_eval id ofs e (ge: genv) b cp le m - (GE1: e ! id = None) + (GE1: wf_env e id) (GE2: Genv.find_symbol ge id = Some b) : eval_expr ge e cp le m (ptr_of_id_ofs id ofs) (Vptr b ofs). @@ -236,40 +238,35 @@ Section Backtranslation. | EVptr_global id ofs => ptr_of_id_ofs id ofs end. - Definition wf_eventval (ge: genv) (e: env) (v: eventval): Prop := + Definition wf_eventval_env (e: env) (v: eventval): Prop := match v with - | EVptr_global id _ => (e ! id = None) /\ (Senv.public_symbol ge id = true) + | EVptr_global id _ => wf_env e id | _ => True end. - Definition wf_eventval_weak (ge: genv) (e: env) (v: eventval): Prop := + Definition wf_eventval_pub (ge: genv) (v: eventval): Prop := match v with - | EVptr_global id _ => (e ! id = None) /\ (exists b, Genv.find_symbol ge id = Some b) + | EVptr_global id _ => (Senv.public_symbol ge id = true) | _ => True end. - Lemma wf_eventval_weak_weak - ge e v - : - wf_eventval ge e v -> wf_eventval_weak ge e v. - Proof. intros H. destruct v; simpl in *; auto. destruct H. split; auto. apply Genv.public_symbol_exists in H0. auto. Qed. - - Definition wf_eventval_weak2 (ge: genv) (v: eventval): Prop := + Definition wf_eventval_ge (ge: genv) (v: eventval): Prop := match v with | EVptr_global id _ => (exists b, Genv.find_symbol ge id = Some b) | _ => True end. - Lemma wf_eventval_weak2_weak - ge e v + Lemma wf_eventval_pub_ge + ge v : - wf_eventval_weak ge e v -> wf_eventval_weak2 ge v. - Proof. intros H. destruct v; simpl in *; auto. destruct H. auto. Qed. + wf_eventval_pub ge v -> wf_eventval_ge ge v. + Proof. intros H. destruct v; simpl in *; auto. apply Genv.public_symbol_exists in H; auto. Qed. Lemma eventval_to_expr_match ge env cp le m ev exp v ty - (WFEV: wf_eventval ge env ev) + (WFENV: wf_eventval_env env ev) + (WFGE: wf_eventval_pub ge ev) (CONV: eventval_to_expr ev = exp) (EVAL: eval_expr ge env cp le m exp v) (TYPE: typ_of_type (eventval_to_type ev) = ty) @@ -281,7 +278,7 @@ Section Backtranslation. - inversion EVAL; subst; simpl in *; try constructor. inversion H. - inversion EVAL; subst; simpl in *; try constructor. inversion H. - inversion EVAL; subst; simpl in *; try constructor. inversion H. - - destruct WFEV as [WFEV1 WFEV2]. unfold ptr_of_id_ofs in EVAL. destruct Archi.ptr64 eqn:ARCH. + - unfold ptr_of_id_ofs in EVAL. destruct Archi.ptr64 eqn:ARCH. + inversion EVAL; subst; simpl in *; try constructor. 2:{ inversion H. } inversion H5; subst; simpl in *. @@ -289,7 +286,7 @@ Section Backtranslation. clear H5. inversion H4; subst; simpl in *. 2:{ inversion H. } clear H4. inversion H2; subst; simpl. - { rewrite WFEV1 in H4. inversion H4. } + { rewrite WFENV in H4. inversion H4. } { inversion H6. rewrite Ptrofs.mul_commut, Ptrofs.mul_one. rewrite Ptrofs.add_zero_l. @@ -304,7 +301,7 @@ Section Backtranslation. clear H5. inversion H4; subst; simpl in *. 2:{ inversion H. } clear H4. inversion H2; subst; simpl. - { rewrite WFEV1 in H4. inversion H4. } + { rewrite WFENV in H4. inversion H4. } { inversion H6. rewrite Ptrofs.mul_commut, Ptrofs.mul_one. rewrite Ptrofs.add_zero_l. @@ -341,13 +338,14 @@ Section Backtranslation. Lemma eventval_to_expr_val_eval ge en cp temp m ev - (WF: wf_eventval_weak ge en ev) + (WFENV: wf_eventval_env en ev) + (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. - destruct WF as [WF0 [b WF1]]. - rewrite WF1. unfold ptr_of_id_ofs. destruct Archi.ptr64 eqn:ARCH. + destruct WFGE as [b WFGE]. + rewrite WFGE. unfold ptr_of_id_ofs. destruct Archi.ptr64 eqn:ARCH. - econstructor; try econstructor. eapply eval_Evar_global; eauto. simpl. simpl_expr. rewrite Ptrofs.mul_commut, Ptrofs.mul_one. rewrite Ptrofs.add_zero_l. rewrite Ptrofs.of_int64_to_int64; auto. @@ -359,14 +357,15 @@ Section Backtranslation. Lemma eventval_to_expr_val_match ge env ev exp v ty - (WFEV: wf_eventval ge env ev) + (WFENV: wf_eventval_env env ev) + (WFEV: wf_eventval_pub ge ev) (CONV0: eventval_to_expr ev = exp) (CONV1: eventval_to_val ge ev = v) (TYPE: typ_of_type (eventval_to_type ev) = ty) : eventval_match ge ev ty v. Proof. - subst. eapply eventval_to_expr_match; eauto. eapply eventval_to_expr_val_eval; eauto. apply wf_eventval_weak_weak; auto. + subst. eapply eventval_to_expr_match; eauto. eapply eventval_to_expr_val_eval; eauto. apply wf_eventval_pub_ge; auto. Unshelve. exact default_compartment. exact (PTree.empty val). exact Mem.empty. Qed. @@ -378,34 +377,40 @@ Section Backtranslation. Lemma sem_cast_eventval ge v m - (WFEV: wf_eventval_weak2 ge v) + (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_eval ge en cp temp m evs - (WF: Forall (wf_eventval_weak ge en) 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 WF. induction evs; intros; simpl in *. constructor. - inversion WF; clear WF; subst. econstructor; eauto. eapply eventval_to_expr_val_eval; eauto. - apply sem_cast_eventval. eapply wf_eventval_weak2_weak; eauto. + 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 list_eventval_to_expr_val_match ge env evs exps vs tys - (WFEV: Forall (wf_eventval ge env) evs) + (WFENV: Forall (wf_eventval_env env) evs) + (WFPUB: Forall (wf_eventval_pub ge) evs) (CONV0: list_eventval_to_list_expr evs = exps) (CONV1: list_eventval_to_list_val ge evs = vs) (TYPE: list_eventval_to_typelist evs = tys) : eventval_list_match ge evs (typlist_of_typelist tys) vs. Proof. - move evs at top. revert ge env exps vs tys WFEV CONV0 CONV1 TYPE. induction evs; intros; simpl in *; subst. constructor. - inversion WFEV; clear WFEV; subst. econstructor; eauto. eapply eventval_to_expr_val_match; eauto. + move evs at top. revert ge env exps vs tys WFENV WFPUB CONV0 CONV1 TYPE. + induction evs; intros; simpl in *; subst. constructor. + inversion WFENV; clear WFENV; subst. inversion WFPUB; clear WFPUB; subst. + econstructor; eauto. eapply eventval_to_expr_val_match; eauto. Qed. @@ -455,7 +460,7 @@ Section Backtranslation. p f k e le m (EV: ev = Event_vload ch id ofs v) (* bt should ensure them *) - (GLOB: e ! id = None) + (WFENV: wf_env e id) b (VOL: Senv.block_is_volatile (globalenv p) b = true) (GE: Genv.find_symbol (globalenv p) id = Some b) @@ -498,12 +503,13 @@ Section Backtranslation. p f k e le m (EV: ev = Event_vstore ch id ofs v) (* bt should ensure them *) - (GLOB: e ! id = None) + (WFENV: wf_env e id) b (VOL: Senv.block_is_volatile (globalenv p) b = true) (GE: Genv.find_symbol (globalenv p) id = Some b) (* asm should ensure them *) - (WFSV: wf_eventval_weak (globalenv p) e v) + (WFSV1: wf_eventval_env e v) + (WFSV2: wf_eventval_ge (globalenv p) v) (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) (Val.load_result ch (eventval_to_val (globalenv p) v))) : Star (Clight.semantics1 p) @@ -520,8 +526,8 @@ Section Backtranslation. { eapply ptr_of_id_ofs_eval; eauto. } { unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. } econstructor; eauto. 3: econstructor. - { eapply eventval_to_expr_val_eval. auto. } - { apply sem_cast_eventval. eapply wf_eventval_weak2_weak; eauto. } + { eapply eventval_to_expr_val_eval; auto. } + { apply sem_cast_eventval; auto. } } simpl. repeat econstructor; eauto. @@ -534,8 +540,8 @@ Section Backtranslation. { eapply ptr_of_id_ofs_eval; eauto. } { unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. } econstructor; eauto. 3: econstructor. - { eapply eventval_to_expr_val_eval. auto. } - { apply sem_cast_eventval. eapply wf_eventval_weak2_weak; eauto. } + { eapply eventval_to_expr_val_eval; auto. } + { apply sem_cast_eventval; auto. } } simpl. repeat econstructor; eauto. @@ -549,7 +555,8 @@ Section Backtranslation. p f k e le m (EV: ev = Event_annot str vs) (* bt should ensure them *) - (WF: Forall (wf_eventval (globalenv p) e) vs) + (WFENV: Forall (wf_eventval_env e) vs) + (WFPUB: Forall (wf_eventval_pub (globalenv p)) vs) (* asm should ensure them *) : Star (Clight.semantics1 p) @@ -561,7 +568,8 @@ Section Backtranslation. econstructor 2. 3:{ rewrite E0_right. reflexivity. } { eapply step_builtin. - { eapply list_eventval_to_expr_val_eval. eapply Forall_impl. 2: eauto. intros. apply wf_eventval_weak_weak; auto. } + { eapply list_eventval_to_expr_val_eval; auto. + eapply Forall_impl. 2: eauto. intros. apply wf_eventval_pub_ge; auto. } repeat econstructor; eauto. eapply list_eventval_to_expr_val_match; eauto. } econstructor 1. @@ -581,7 +589,8 @@ Section Backtranslation. fd (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) (TYPEF: type_of_fundef fd = Tfunction (list_eventval_to_typelist vs) Tvoid cc_default) - (WFARGS: Forall (wf_eventval ge e) vs) + (WFARGS1: Forall (wf_eventval_env e) vs) + (WFARGS2: Forall (wf_eventval_pub ge) vs) (* asm should ensure them *) (CP1: cp = comp_of f) (CP2: cp' = comp_of fd) @@ -602,7 +611,8 @@ Section Backtranslation. - eapply eval_Evar_global; eauto. - eapply deref_loc_reference. auto. } - { eapply list_eventval_to_expr_val_eval. eapply Forall_impl. 2: eauto. intros. apply wf_eventval_weak_weak; auto. } + { eapply list_eventval_to_expr_val_eval; auto. + eapply Forall_impl. 2: eauto. intros. apply wf_eventval_pub_ge; auto. } red; auto. unfold Genv.find_comp. setoid_rewrite FINDF. eapply call_trace_cross; eauto. apply Genv.find_invert_symbol; auto. @@ -670,7 +680,8 @@ Section Backtranslation. (GE: ge = globalenv p) (EV: ev = Event_return cp' cp rv) (* bt should ensure them *) - (WFRV: wf_eventval ge e rv) + (WFRV1: wf_eventval_env e rv) + (WFRV2: wf_eventval_pub ge rv) (RTTYP: fn_return f = eventval_to_type rv) (* asm should ensure them *) optid f' e' le' k' @@ -692,9 +703,8 @@ Section Backtranslation. econstructor 2. 3:{ rewrite E0_left. reflexivity. } { eapply step_return_1; simpl; eauto. - { eapply eventval_to_expr_val_eval; auto. apply wf_eventval_weak_weak; auto. } - { rewrite RTTYP. eapply sem_cast_eventval. - eapply wf_eventval_weak2_weak. eapply wf_eventval_weak_weak; eauto. } + { eapply eventval_to_expr_val_eval; auto. apply wf_eventval_pub_ge; auto. } + { rewrite RTTYP. eapply sem_cast_eventval; auto. eapply wf_eventval_pub_ge; eauto. } } econstructor 2. 3:{ rewrite E0_right. reflexivity. } @@ -705,32 +715,16 @@ Section Backtranslation. econstructor 1. Qed. - (* TODO *) - End CODE. Section PROJ. (** Projection of the trace according to compartments **) - (* Definition curr_comp_of_event (e: event): option compartment := *) - (* match e with *) - (* | Event_call cp cp' id vs => Some cp *) - (* | Event_return cp cp' v => Some cp' *) - (* | _ => None *) - (* end. *) - - (* Definition next_comp_of_event (e: event): option compartment := *) - (* match e with *) - (* | Event_call cp cp' id vs => Some cp' *) - (* | Event_return cp cp' v => Some cp *) - (* | _ => None *) - (* end. *) - Definition comp_of_event (e: event): option (compartment * compartment) := match e with | Event_call cp cp' id vs => Some (cp, cp') - | Event_return cp cp' v => Some (cp', cp) + | Event_return cp' cp v => Some (cp, cp') | _ => None end. @@ -759,6 +753,286 @@ Section Backtranslation. End PROJ. + Section WELLFORMED. + + Variable p: program. + Let ge := globalenv p. + + (** Well-formed conditions for the trace, namely from the semantics of Asm **) + Definition wf_trace_vload ch v := + exists rv, eventval_match (globalenv p) v (type_of_chunk ch) rv. + + + (** Well-formed conditions for the back-translated program **) + Definition wf_bt_vload (e: env) id := + (wf_env e id) /\ + (exists b, (Genv.find_symbol ge id = Some b) /\ (Senv.block_is_volatile ge b = true)). + + + Lemma code_of_event_step_vload + ev + ch id ofs v + p f k e le m + (EV: ev = Event_vload ch id ofs v) + (* bt should ensure them *) + (WFENV: wf_env e id) + b + (VOL: Senv.block_is_volatile (globalenv p) b = true) + (GE: Genv.find_symbol (globalenv p) id = Some b) + (* asm should ensure them *) + rv + (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) rv) + : + Star (Clight.semantics1 p) + (State f (code_of_event ev) k e le m) + (ev :: nil) + (State f Sskip k e le m). + Proof. + subst; simpl in *. unfold code_of_vload. + destruct Archi.ptr64 eqn:ARCH. + - econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_builtin. + { econstructor; eauto. 3: econstructor. + - eapply ptr_of_id_ofs_eval; eauto. + - unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. + } + repeat econstructor; eauto. + } + econstructor 1. + - econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_builtin. + { econstructor; eauto. 3: econstructor. + - eapply ptr_of_id_ofs_eval; eauto. + - unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. + } + repeat econstructor; eauto. + } + econstructor 1. + Qed. + + Lemma code_of_event_step_vstore + ev + ch id ofs v + p f k e le m + (EV: ev = Event_vstore ch id ofs v) + (* bt should ensure them *) + (WFENV: wf_env e id) + b + (VOL: Senv.block_is_volatile (globalenv p) b = true) + (GE: Genv.find_symbol (globalenv p) id = Some b) + (* asm should ensure them *) + (WFSV1: wf_eventval_env e v) + (WFSV2: wf_eventval_ge (globalenv p) v) + (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) (Val.load_result ch (eventval_to_val (globalenv p) v))) + : + Star (Clight.semantics1 p) + (State f (code_of_event ev) k e le m) + (ev :: nil) + (State f Sskip k e le m). + Proof. + subst; simpl in *. unfold code_of_vstore. + destruct Archi.ptr64 eqn:ARCH. + - econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_builtin. + { econstructor; eauto. + { eapply ptr_of_id_ofs_eval; eauto. } + { unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. } + econstructor; eauto. 3: econstructor. + { eapply eventval_to_expr_val_eval; auto. } + { apply sem_cast_eventval; auto. } + } + simpl. + repeat econstructor; eauto. + } + econstructor 1. + - econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_builtin. + { econstructor; eauto. + { eapply ptr_of_id_ofs_eval; eauto. } + { unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. } + econstructor; eauto. 3: econstructor. + { eapply eventval_to_expr_val_eval; auto. } + { apply sem_cast_eventval; auto. } + } + simpl. + repeat econstructor; eauto. + } + econstructor 1. + Qed. + + Lemma code_of_event_step_annot + ev + str vs + p f k e le m + (EV: ev = Event_annot str vs) + (* bt should ensure them *) + (WFENV: Forall (wf_eventval_env e) vs) + (WFPUB: Forall (wf_eventval_pub (globalenv p)) vs) + (* asm should ensure them *) + : + Star (Clight.semantics1 p) + (State f (code_of_event ev) k e le m) + (ev :: nil) + (State f Sskip k e le m). + Proof. + subst; simpl in *. unfold code_of_annot. + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_builtin. + { eapply list_eventval_to_expr_val_eval; auto. + eapply Forall_impl. 2: eauto. intros. apply wf_eventval_pub_ge; auto. } + repeat econstructor; eauto. eapply list_eventval_to_expr_val_match; eauto. + } + econstructor 1. + Qed. + + Lemma code_of_event_step_call_start + ev + cp cp' id vs + p f k e le m + ge + (GE: ge = globalenv p) + (EV: ev = Event_call cp cp' id vs) + (* bt should ensure them *) + (GLOB: e ! id = None) + b + (FINDB: Genv.find_symbol ge id = Some b) + fd + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (TYPEF: type_of_fundef fd = Tfunction (list_eventval_to_typelist vs) Tvoid cc_default) + (WFARGS1: Forall (wf_eventval_env e) vs) + (WFARGS2: Forall (wf_eventval_pub ge) vs) + (* asm should ensure them *) + (CP1: cp = comp_of f) + (CP2: cp' = comp_of fd) + (NPTR: Forall not_ptr (list_eventval_to_list_val ge vs)) + (CROSS: Genv.type_of_call ge (comp_of f) (comp_of fd) = Genv.CrossCompartmentCall) + (ALLOW: Genv.allowed_cross_call ge (comp_of f) (Vptr b Ptrofs.zero)) + : + Star (Clight.semantics1 p) + (State f (code_of_event ev) k e le m) + (ev :: nil) + (Callstate fd (list_eventval_to_list_val ge vs) (Kcall None f e le k) m). + Proof. + subst; simpl. unfold code_of_call. + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_call; simpl; eauto. + { eapply eval_Elvalue. + - eapply eval_Evar_global; eauto. + - eapply deref_loc_reference. auto. + } + { eapply list_eventval_to_expr_val_eval; auto. + eapply Forall_impl. 2: eauto. intros. apply wf_eventval_pub_ge; auto. } + red; auto. + unfold Genv.find_comp. setoid_rewrite FINDF. + eapply call_trace_cross; eauto. apply Genv.find_invert_symbol; auto. + eapply (list_eventval_to_expr_val_match (globalenv p)); eauto. + } + econstructor 1. + Qed. + + Lemma code_of_event_step_call_internal + p f k e le m + ge + (GE: ge = globalenv p) + (* bt should ensure them *) + fd args f1 + (INTERNAL: fd = Internal f1) + (* asm should ensure them *) + (* handle during proving *) + e1 le1 m1 + (ENTRY: function_entry1 ge f1 args m e1 le1 m1) + : + Star (Clight.semantics1 p) + (Callstate fd args (Kcall None f e le k) m) + nil + (State f1 (fn_body f1) (Kcall None f e le k) e1 le1 m1). + Proof. + subst; simpl. + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_internal_function; eauto. } + econstructor 1. + Qed. + + Lemma code_of_event_step_call_external + p m + ge + (GE: ge = globalenv p) + (* bt should ensure them *) + fd k args ef targs tres cconv + (EXTERNAL: fd = External ef targs tres cconv) + (* asm should ensure them *) + sev + vres m1 + (SEM: external_call ef ge (call_comp k) args m (sev :: nil) vres m1) + (* handle during proving *) + sname sargs svr + (SYSEV: sev = Event_syscall sname sargs svr) + : + Star (Clight.semantics1 p) + (Callstate fd args k m) + (sev :: nil) + (Returnstate vres k m1 (rettype_of_type tres) (comp_of ef)). + Proof. + subst; simpl. + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_external_function; eauto. } + econstructor 1. + Qed. + + Lemma code_of_event_step_return + ev + cp cp' rv + p f k e le m + ge + (GE: ge = globalenv p) + (EV: ev = Event_return cp' cp rv) + (* bt should ensure them *) + (WFRV1: wf_eventval_env e rv) + (WFRV2: wf_eventval_pub ge rv) + (RTTYP: fn_return f = eventval_to_type rv) + (* asm should ensure them *) + optid f' e' le' k' + (CONT: call_cont k = Kcall optid f' e' le' k') + (CP1: cp = comp_of f) + (CP2: cp' = comp_of f') + (NPTR: not_ptr (eventval_to_val ge rv)) + (CROSS: Genv.type_of_call ge (comp_of f') (comp_of f) = Genv.CrossCompartmentCall) + (* handle during proving *) + m' + (FREE: Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m') + : + Star (Clight.semantics1 p) + (State f (code_of_event ev) k e le m) + (ev :: nil) + (State f' Sskip k' e' (set_opttemp optid (eventval_to_val ge rv) le') m'). + Proof. + subst; simpl. unfold code_of_return. + econstructor 2. + 3:{ rewrite E0_left. reflexivity. } + { eapply step_return_1; simpl; eauto. + { eapply eventval_to_expr_val_eval; auto. apply wf_eventval_pub_ge; auto. } + { rewrite RTTYP. eapply sem_cast_eventval; auto. eapply wf_eventval_pub_ge; eauto. } + } + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { rewrite CONT. eapply step_returnstate; auto. + econstructor 2; auto. rewrite RTTYP. eapply eventval_to_expr_val_match; eauto. + clear. destruct rv; simpl; auto. + } + econstructor 1. + Qed. + + End WELLFORMED. + + (* TODO *) (* Axiom backtranslation: Policy.t -> split -> trace -> Clight.program * Clight.program. *) (* Axiom backtranslation_correct: *) From 62c65f7b92610fb1c078d38b4ad034101c33542c Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 17 Apr 2023 17:32:27 +0200 Subject: [PATCH 014/174] WIP --- security/Backtranslation.v | 247 +++++++------------------------------ 1 file changed, 45 insertions(+), 202 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 7f7a8a5992..2bae4ec895 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -4,6 +4,7 @@ Require Import AST Linking Smallstep Events Behaviors. Require Import Split. +Require Import riscV.Asm. Require Import Ctypes Clight. Record backtranslation_environment := @@ -753,188 +754,60 @@ Section Backtranslation. End PROJ. - Section WELLFORMED. + Section FROMASM. + (** Well-formed conditions for the trace, namely from the semantics of Asm **) - Variable p: program. - Let ge := globalenv p. + Variable p: Asm.program. + Let ge := Genv.globalenv p. - (** Well-formed conditions for the trace, namely from the semantics of Asm **) - Definition wf_trace_vload ch v := - exists rv, eventval_match (globalenv p) v (type_of_chunk ch) rv. + Definition wf_tr_vload ch (id: ident) (ofs: ptrofs) v := + exists rv, eventval_match ge v (type_of_chunk ch) rv. + + (* TODO: fix eventval_to_val *) + (* Definition wf_tr_vstore ch (id: ident) (ofs: ptrofs) v := *) + (* eventval_match ge v (type_of_chunk ch) (Val.load_result ch (eventval_to_val ge v)). *) + + Definition wf_tr_annot (str: string) (vs: list eventval) := True. + (* TODO: fix *) + Definition wf_tr_call_start (cp cp': compartment) (id: ident) (vs: list eventval) := + (* (Forall not_ptr (list_eventval_to_list_val ge vs)) /\ *) + (Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) /\ + (exists l1, ((Policy.policy_import (Genv.genv_policy ge)) ! cp = Some l1) /\ (In (cp', id) l1)) /\ + (exists l2, ((Policy.policy_export (Genv.genv_policy ge)) ! cp' = Some l2) /\ (In id l2)). + End FROMASM. + + + Section WELLFORMED. (** Well-formed conditions for the back-translated program **) - Definition wf_bt_vload (e: env) id := + + Variable p: program. + Let ge := globalenv p. + + Definition wf_bt_vload (ch: memory_chunk) (id: ident) (ofs: ptrofs) (v: eventval) e := (wf_env e id) /\ (exists b, (Genv.find_symbol ge id = Some b) /\ (Senv.block_is_volatile ge b = true)). - - Lemma code_of_event_step_vload - ev - ch id ofs v - p f k e le m - (EV: ev = Event_vload ch id ofs v) - (* bt should ensure them *) - (WFENV: wf_env e id) - b - (VOL: Senv.block_is_volatile (globalenv p) b = true) - (GE: Genv.find_symbol (globalenv p) id = Some b) - (* asm should ensure them *) - rv - (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) rv) - : - Star (Clight.semantics1 p) - (State f (code_of_event ev) k e le m) - (ev :: nil) - (State f Sskip k e le m). - Proof. - subst; simpl in *. unfold code_of_vload. - destruct Archi.ptr64 eqn:ARCH. - - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_builtin. - { econstructor; eauto. 3: econstructor. - - eapply ptr_of_id_ofs_eval; eauto. - - unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. - } - repeat econstructor; eauto. - } - econstructor 1. - - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_builtin. - { econstructor; eauto. 3: econstructor. - - eapply ptr_of_id_ofs_eval; eauto. - - unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. - } - repeat econstructor; eauto. - } - econstructor 1. - Qed. + Definition wf_bt_vstore (ch: memory_chunk) (id: ident) (ofs: ptrofs) v e := + (wf_eventval_env e v) /\ (wf_eventval_ge ge v) /\ (wf_env e id) /\ + (exists b, (Genv.find_symbol ge id = Some b) /\ (Senv.block_is_volatile ge b = true)). - Lemma code_of_event_step_vstore - ev - ch id ofs v - p f k e le m - (EV: ev = Event_vstore ch id ofs v) - (* bt should ensure them *) - (WFENV: wf_env e id) - b - (VOL: Senv.block_is_volatile (globalenv p) b = true) - (GE: Genv.find_symbol (globalenv p) id = Some b) - (* asm should ensure them *) - (WFSV1: wf_eventval_env e v) - (WFSV2: wf_eventval_ge (globalenv p) v) - (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) (Val.load_result ch (eventval_to_val (globalenv p) v))) - : - Star (Clight.semantics1 p) - (State f (code_of_event ev) k e le m) - (ev :: nil) - (State f Sskip k e le m). - Proof. - subst; simpl in *. unfold code_of_vstore. - destruct Archi.ptr64 eqn:ARCH. - - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_builtin. - { econstructor; eauto. - { eapply ptr_of_id_ofs_eval; eauto. } - { unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. } - econstructor; eauto. 3: econstructor. - { eapply eventval_to_expr_val_eval; auto. } - { apply sem_cast_eventval; auto. } - } - simpl. - repeat econstructor; eauto. - } - econstructor 1. - - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_builtin. - { econstructor; eauto. - { eapply ptr_of_id_ofs_eval; eauto. } - { unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. } - econstructor; eauto. 3: econstructor. - { eapply eventval_to_expr_val_eval; auto. } - { apply sem_cast_eventval; auto. } - } - simpl. - repeat econstructor; eauto. - } - econstructor 1. - Qed. + Definition wf_bt_annot (str: string) (vs: list eventval) e := + (Forall (wf_eventval_env e) vs) /\ (Forall (wf_eventval_pub ge) vs). - Lemma code_of_event_step_annot - ev - str vs - p f k e le m - (EV: ev = Event_annot str vs) - (* bt should ensure them *) - (WFENV: Forall (wf_eventval_env e) vs) - (WFPUB: Forall (wf_eventval_pub (globalenv p)) vs) - (* asm should ensure them *) - : - Star (Clight.semantics1 p) - (State f (code_of_event ev) k e le m) - (ev :: nil) - (State f Sskip k e le m). - Proof. - subst; simpl in *. unfold code_of_annot. - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_builtin. - { eapply list_eventval_to_expr_val_eval; auto. - eapply Forall_impl. 2: eauto. intros. apply wf_eventval_pub_ge; auto. } - repeat econstructor; eauto. eapply list_eventval_to_expr_val_match; eauto. - } - econstructor 1. - Qed. + Definition wf_bt_call_start (cp cp': compartment) (id: ident) (vs: list eventval) e := + (wf_env e id) /\ + (Forall (wf_eventval_env e) vs) /\ + (Forall (wf_eventval_pub ge) vs) /\ + (exists b fd, + (Genv.find_symbol ge id = Some b) /\ + (Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) /\ + (type_of_fundef fd = Tfunction (list_eventval_to_typelist vs) Tvoid cc_default) /\ + (cp' = comp_of fd) + ). - Lemma code_of_event_step_call_start - ev - cp cp' id vs - p f k e le m - ge - (GE: ge = globalenv p) - (EV: ev = Event_call cp cp' id vs) - (* bt should ensure them *) - (GLOB: e ! id = None) - b - (FINDB: Genv.find_symbol ge id = Some b) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (TYPEF: type_of_fundef fd = Tfunction (list_eventval_to_typelist vs) Tvoid cc_default) - (WFARGS1: Forall (wf_eventval_env e) vs) - (WFARGS2: Forall (wf_eventval_pub ge) vs) - (* asm should ensure them *) - (CP1: cp = comp_of f) - (CP2: cp' = comp_of fd) - (NPTR: Forall not_ptr (list_eventval_to_list_val ge vs)) - (CROSS: Genv.type_of_call ge (comp_of f) (comp_of fd) = Genv.CrossCompartmentCall) - (ALLOW: Genv.allowed_cross_call ge (comp_of f) (Vptr b Ptrofs.zero)) - : - Star (Clight.semantics1 p) - (State f (code_of_event ev) k e le m) - (ev :: nil) - (Callstate fd (list_eventval_to_list_val ge vs) (Kcall None f e le k) m). - Proof. - subst; simpl. unfold code_of_call. - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_call; simpl; eauto. - { eapply eval_Elvalue. - - eapply eval_Evar_global; eauto. - - eapply deref_loc_reference. auto. - } - { eapply list_eventval_to_expr_val_eval; auto. - eapply Forall_impl. 2: eauto. intros. apply wf_eventval_pub_ge; auto. } - red; auto. - unfold Genv.find_comp. setoid_rewrite FINDF. - eapply call_trace_cross; eauto. apply Genv.find_invert_symbol; auto. - eapply (list_eventval_to_expr_val_match (globalenv p)); eauto. - } - econstructor 1. - Qed. + (* TODO: need a proof invariant - related to continuation/stack/function *) Lemma code_of_event_step_call_internal p f k e le m @@ -952,13 +825,6 @@ Section Backtranslation. (Callstate fd args (Kcall None f e le k) m) nil (State f1 (fn_body f1) (Kcall None f e le k) e1 le1 m1). - Proof. - subst; simpl. - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_internal_function; eauto. } - econstructor 1. - Qed. Lemma code_of_event_step_call_external p m @@ -979,13 +845,6 @@ Section Backtranslation. (Callstate fd args k m) (sev :: nil) (Returnstate vres k m1 (rettype_of_type tres) (comp_of ef)). - Proof. - subst; simpl. - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_external_function; eauto. } - econstructor 1. - Qed. Lemma code_of_event_step_return ev @@ -997,7 +856,6 @@ Section Backtranslation. (* bt should ensure them *) (WFRV1: wf_eventval_env e rv) (WFRV2: wf_eventval_pub ge rv) - (RTTYP: fn_return f = eventval_to_type rv) (* asm should ensure them *) optid f' e' le' k' (CONT: call_cont k = Kcall optid f' e' le' k') @@ -1006,6 +864,7 @@ Section Backtranslation. (NPTR: not_ptr (eventval_to_val ge rv)) (CROSS: Genv.type_of_call ge (comp_of f') (comp_of f) = Genv.CrossCompartmentCall) (* handle during proving *) + (RTTYP: fn_return f = eventval_to_type rv) m' (FREE: Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m') : @@ -1013,22 +872,6 @@ Section Backtranslation. (State f (code_of_event ev) k e le m) (ev :: nil) (State f' Sskip k' e' (set_opttemp optid (eventval_to_val ge rv) le') m'). - Proof. - subst; simpl. unfold code_of_return. - econstructor 2. - 3:{ rewrite E0_left. reflexivity. } - { eapply step_return_1; simpl; eauto. - { eapply eventval_to_expr_val_eval; auto. apply wf_eventval_pub_ge; auto. } - { rewrite RTTYP. eapply sem_cast_eventval; auto. eapply wf_eventval_pub_ge; eauto. } - } - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { rewrite CONT. eapply step_returnstate; auto. - econstructor 2; auto. rewrite RTTYP. eapply eventval_to_expr_val_match; eauto. - clear. destruct rv; simpl; auto. - } - econstructor 1. - Qed. End WELLFORMED. From bc2603ca4e16155b791a3f08ea223c9c2f43071b Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 18 Apr 2023 16:57:48 +0200 Subject: [PATCH 015/174] major changes - non-public global vars for counters, use Asm.program --- security/Backtranslation.v | 433 +++++++++++++++++++------------------ 1 file changed, 227 insertions(+), 206 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 2bae4ec895..c4b5b302a6 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -7,15 +7,16 @@ Require Import Split. Require Import riscV.Asm. Require Import Ctypes Clight. -Record backtranslation_environment := - { local_counter: compartment -> ident }. +(* Record backtranslation_environment := *) +(* { local_counter: compartment -> ident }. *) Section Backtranslation. Ltac simpl_expr := repeat (match goal with | |- eval_expr _ _ _ _ _ _ _ => econstructor - | |- eval_lvalue _ _ _ _ _ _ _ _ _ => econstructor + | |- eval_lvalue _ _ _ _ _ _ _ _ _ => econstructor 2 + (* | |- eval_lvalue _ _ _ _ _ _ _ _ _ => econstructor *) | |- deref_loc _ _ _ _ _ _ _ => econstructor | |- assign_loc _ _ _ _ _ _ _ _ _ => econstructor | |- Cop.sem_cmp _ _ _ _ _ _ = Some _ => unfold Cop.sem_cmp @@ -29,7 +30,7 @@ Section Backtranslation. Ltac take_step := econstructor; [econstructor; simpl_expr | | traceEq]; simpl. - Variable bt_env: backtranslation_environment. + (* Variable bt_env: backtranslation_environment. *) Section SWITCH. (** switch statement; use to convert a trace to a code **) @@ -37,16 +38,16 @@ Section Backtranslation. 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 := + 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) + (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. @@ -56,19 +57,22 @@ Section Backtranslation. Ltac take_step' := econstructor; [econstructor; simpl_expr' | | traceEq]; simpl. - Lemma switch_clause_spec p (cp: compartment) f (e: env) le m b (n: int64) (n': Z) s_then s_else: - cp = comp_of f -> - e ! (bt_env.(local_counter) cp) = Some (b, type_counter) -> + Lemma switch_clause_spec p (cnt: ident) f e le m b (n: int64) (n': Z) s_then s_else: + let cp := comp_of f in + let ge := globalenv p in + e ! cnt = None -> + Genv.find_symbol ge cnt = Some b -> + (* e ! cnt = Some (b, type_counter) -> *) 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 Mint64 m (Vptr b Ptrofs.zero) (Vlong (Int64.add n Int64.one)) cp = Some m' /\ - 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') + Star (Clight.semantics1 p) (State f (switch_clause cnt n' s_then s_else) Kstop e le m) E0 (State f s_then Kstop 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). + Star (Clight.semantics1 p) (State f (switch_clause cnt n' s_then s_else) Kstop e le m) E0 (State f s_else Kstop e le m). Proof. - intros; subst cp. + intros; subst cp ge. 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. @@ -81,39 +85,42 @@ Section Backtranslation. Qed. - Definition switch_add_statement cp s res := - (Z.pred (fst res), switch_clause cp (Z.pred (fst res)) s (snd res)). + Definition switch_add_statement cnt s res := + (Z.pred (fst res), switch_clause cnt (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). + 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 (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. + 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 (e: env) le m b (n: Z) ss s_else + p (cnt: ident) f (e: env) le m b (n: Z) ss s_else (WF: Z.of_nat (length ss) < Int64.modulus) (RANGE: Z.of_nat (length ss) <= n < Int64.modulus) : - cp = comp_of f -> - e ! (bt_env.(local_counter) cp) = Some (b, type_counter) -> + let ge := globalenv p in + let cp := comp_of f in + e ! cnt = None -> + Genv.find_symbol ge cnt = Some b -> + (* e ! (bt_env.(local_counter) cp) = Some (b, type_counter) -> *) (* Mem.valid_access m Mint64 b 0 Writable (Some cp) -> *) Mem.loadv Mint64 m (Vptr b Ptrofs.zero) (Some cp) = Some (Vlong (Int64.repr n)) -> Star (Clight.semantics1 p) - (State f (switch cp ss s_else) Kstop e le m) + (State f (switch cnt ss s_else) Kstop e le m) E0 (State f s_else Kstop e le m). Proof. - intros; subst cp. unfold switch. destruct RANGE as [RA1 RA2]. + intros; subst cp ge. unfold switch. destruct RANGE as [RA1 RA2]. assert (G: forall n', (Z.of_nat (length ss)) <= n' -> n' <= n -> Star (Clight.semantics1 p) - (State f (snd (fold_right (switch_add_statement (comp_of f)) (n', s_else) ss)) Kstop e le m) + (State f (snd (fold_right (switch_add_statement cnt) (n', s_else) ss)) Kstop e le m) E0 (State f s_else Kstop e le m)). { intros n' LE1 LE2. @@ -138,35 +145,38 @@ Section Backtranslation. Let nat64 n := Int64.repr (Z.of_nat n). Lemma switch_spec - p (cp: compartment) f (e: env) le m b + p (cnt: ident) f (e: env) le m b ss s ss' s_else (WF: Z.of_nat (length (ss ++ s :: ss')) < Int64.modulus) : - cp = comp_of f -> - e ! (bt_env.(local_counter) cp) = Some (b, type_counter) -> + let ge := globalenv p in + let cp := comp_of f in + e ! cnt = None -> + Genv.find_symbol ge cnt = Some b -> + (* e ! (bt_env.(local_counter) cp) = Some (b, type_counter) -> *) 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 (Clight.semantics1 p) - (State f (switch cp (ss ++ s :: ss') s_else) Kstop e le m) + (State f (switch cnt (ss ++ s :: ss') s_else) Kstop e le m) E0 (State f s Kstop e le m'). Proof. intros. assert (Eswitch : exists s_else', - switch cp (ss ++ s :: ss') s_else = - switch cp ss (switch_clause cp (Z.of_nat (length ss)) s 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 cp) (Z.of_nat (length ss + S (length ss')), s_else) ss')). + 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 p cp f e le m b (nat64 (length ss)) (Z.of_nat (length ss)) s s_else); auto. + exploit (switch_clause_spec p cnt f e le m b (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. @@ -179,8 +189,12 @@ Section Backtranslation. End SWITCH. - Section CODE. - (** converting trace to code **) + Section CONV. + (** converting event to data **) + + Context {F: Type}. + Context {V: Type}. + Variable ge: Genv.t F V. Definition wf_env (e: env) id := e ! id = None. @@ -206,24 +220,6 @@ Section Backtranslation. (Econst_int (Ptrofs.to_int ofs) (Tint I32 Signed noattr)) (Tpointer Tvoid noattr). - Lemma ptr_of_id_ofs_eval - id ofs e (ge: genv) b cp le m - (GE1: wf_env e id) - (GE2: Genv.find_symbol ge id = Some b) - : - eval_expr ge e cp le m (ptr_of_id_ofs id ofs) (Vptr b ofs). - Proof. - 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 ptr_of_id_ofs_typeof i i0 : @@ -245,26 +241,121 @@ Section Backtranslation. | _ => True end. - Definition wf_eventval_pub (ge: genv) (v: eventval): Prop := + Definition wf_eventval_pub (v: eventval): Prop := match v with | EVptr_global id _ => (Senv.public_symbol ge id = true) | _ => True end. - Definition wf_eventval_ge (ge: genv) (v: eventval): Prop := + Definition wf_eventval_ge (v: eventval): Prop := match v with | EVptr_global id _ => (exists b, Genv.find_symbol ge id = Some b) | _ => True end. Lemma wf_eventval_pub_ge - ge v + v : - wf_eventval_pub ge v -> wf_eventval_ge ge v. + wf_eventval_pub v -> wf_eventval_ge v. Proof. intros H. destruct v; simpl in *; auto. apply Genv.public_symbol_exists in H; auto. Qed. + 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. + + 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 list_eventval_to_list_expr (vs: list eventval): list expr := + List.map eventval_to_expr vs. + + Definition list_eventval_to_list_val (vs: list eventval): list val := + List.map (eventval_to_val) vs. + + 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. + + End CONV. + + + Section CODE. + (** converting trace to code **) + + (* converting functions *) + 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) (Tcons (eventval_to_type v) Tnil)) ((ptr_of_id_ofs id ofs) :: (eventval_to_expr v) :: nil). + + 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). + + (* 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_return (cp cp': compartment) (v: eventval) := + Sreturn (Some (eventval_to_expr v)). + + Definition code_of_event (e: event): statement := + match e with + | 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_syscall name vs v => code_of_syscall name vs v + | Event_return cp cp' v => code_of_return cp cp' v + end. + + (* A while(1)-loop with a big switch inside it *) + Definition code_of_trace cp (t: trace): statement := + Swhile (Econst_int Int.one (Tint I32 Signed noattr)) (switch cp (map code_of_event t) (Sreturn None)). + + + (* Properties *) + + Lemma ptr_of_id_ofs_eval + id ofs e (ge: genv) b cp le m + (GE1: wf_env e id) + (GE2: Genv.find_symbol ge id = Some b) + : + eval_expr ge e cp le m (ptr_of_id_ofs id ofs) (Vptr b ofs). + Proof. + 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 eventval_to_expr_match - ge env cp le m + (ge: genv) env cp le m ev exp v ty (WFENV: wf_eventval_env env ev) (WFGE: wf_eventval_pub ge ev) @@ -313,32 +404,8 @@ Section Backtranslation. } Qed. - Definition eventval_to_val (ge: genv) (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. - - 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 list_eventval_to_list_expr (vs: list eventval): list expr := - List.map eventval_to_expr vs. - - Definition list_eventval_to_list_val (ge: genv) (vs: list eventval): list val := - List.map (eventval_to_val ge) vs. - Lemma eventval_to_expr_val_eval - ge en cp temp m ev + (ge: genv) en cp temp m ev (WFENV: wf_eventval_env en ev) (WFGE: wf_eventval_ge ge ev) : @@ -356,7 +423,7 @@ Section Backtranslation. Qed. Lemma eventval_to_expr_val_match - ge env + (ge: genv) env ev exp v ty (WFENV: wf_eventval_env env ev) (WFEV: wf_eventval_pub ge ev) @@ -370,21 +437,15 @@ Section Backtranslation. Unshelve. exact default_compartment. exact (PTree.empty val). exact Mem.empty. Qed. - 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. - Lemma sem_cast_eventval - ge v m + (ge: genv) 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_eval - ge en cp temp m evs + (ge: genv) en cp temp m evs (WFENV: Forall (wf_eventval_env en) evs) (WFGE: Forall (wf_eventval_ge ge) evs) : @@ -398,7 +459,7 @@ Section Backtranslation. Qed. Lemma list_eventval_to_expr_val_match - ge env + (ge: genv) env evs exps vs tys (WFENV: Forall (wf_eventval_env env) evs) (WFPUB: Forall (wf_eventval_pub ge) evs) @@ -415,46 +476,6 @@ Section Backtranslation. Qed. - (* converting functions *) - 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) (Tcons (eventval_to_type v) Tnil)) ((ptr_of_id_ofs id ofs) :: (eventval_to_expr v) :: nil). - - 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). - - (* 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_return (cp cp': compartment) (v: eventval) := - Sreturn (Some (eventval_to_expr v)). - - Definition code_of_event (e: event): statement := - match e with - | 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_syscall name vs v => code_of_syscall name vs v - | Event_return cp cp' v => code_of_return cp cp' v - end. - - (* A while(1)-loop with a big switch inside it *) - Definition code_of_trace cp (t: trace): statement := - Swhile (Econst_int Int.one (Tint I32 Signed noattr)) (switch cp (map code_of_event t) (Sreturn None)). - - - (* Properties *) Lemma code_of_event_step_vload ev ch id ofs v @@ -780,51 +801,78 @@ Section Backtranslation. Section WELLFORMED. - (** Well-formed conditions for the back-translated program **) - - Variable p: program. - Let ge := globalenv p. - Definition wf_bt_vload (ch: memory_chunk) (id: ident) (ofs: ptrofs) (v: eventval) e := - (wf_env e id) /\ - (exists b, (Genv.find_symbol ge id = Some b) /\ (Senv.block_is_volatile ge b = true)). - - Definition wf_bt_vstore (ch: memory_chunk) (id: ident) (ofs: ptrofs) v e := - (wf_eventval_env e v) /\ (wf_eventval_ge ge v) /\ (wf_env e id) /\ - (exists b, (Genv.find_symbol ge id = Some b) /\ (Senv.block_is_volatile ge b = true)). - - Definition wf_bt_annot (str: string) (vs: list eventval) e := - (Forall (wf_eventval_env e) vs) /\ (Forall (wf_eventval_pub ge) vs). - - Definition wf_bt_call_start (cp cp': compartment) (id: ident) (vs: list eventval) e := - (wf_env e id) /\ - (Forall (wf_eventval_env e) vs) /\ - (Forall (wf_eventval_pub ge) vs) /\ - (exists b fd, - (Genv.find_symbol ge id = Some b) /\ - (Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) /\ - (type_of_fundef fd = Tfunction (list_eventval_to_typelist vs) Tvoid cc_default) /\ - (cp' = comp_of fd) - ). - - (* TODO: need a proof invariant - related to continuation/stack/function *) - - Lemma code_of_event_step_call_internal - p f k e le m - ge - (GE: ge = globalenv p) - (* bt should ensure them *) - fd args f1 - (INTERNAL: fd = Internal f1) - (* asm should ensure them *) - (* handle during proving *) - e1 le1 m1 - (ENTRY: function_entry1 ge f1 args m e1 le1 m1) - : - Star (Clight.semantics1 p) - (Callstate fd args (Kcall None f e le k) m) - nil - (State f1 (fn_body f1) (Kcall None f e le k) e1 le1 m1). + (* wf_sem *) + Definition wf_sem_vload {F V} (ge: Genv.t F V) (ch: memory_chunk) (id: ident) (ofs: ptrofs) (v: eventval) := + (exists b, (Genv.find_symbol ge id = Some b) /\ (Senv.block_is_volatile ge b = true)) /\ + (exists rv, (eventval_match ge v (type_of_chunk ch) rv)). + + Definition wf_sem_vstore {F V} (ge: Genv.t F V) (ch: memory_chunk) (id: ident) (ofs: ptrofs) v := + (exists b, (Genv.find_symbol ge id = Some b) /\ (Senv.block_is_volatile ge b = true)) /\ + (wf_eventval_ge ge v) /\ + (eventval_match ge v (type_of_chunk ch) (Val.load_result ch (eventval_to_val ge v))). + + Definition wf_sem_annot {F V} (ge: Genv.t F V) (str: string) (vs: list eventval) := + (Forall (wf_eventval_pub ge) vs). + + Definition wf_sem_call_internal {F V} {CF: has_comp F} (FD: F -> Prop) (ge: Genv.t F V) (cp cp': compartment) (id: ident) (vs: list eventval) := + (Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) /\ + ((Forall (wf_eventval_pub ge) vs) /\ (Forall not_ptr (list_eventval_to_list_val ge vs))) /\ + exists b, + (Genv.find_symbol ge id = Some b) /\ (Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) /\ + (exists fd, (Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) /\ (cp' = comp_of fd) /\ (FD fd)). + (* (TYPEF: type_of_fundef fd = Tfunction (list_eventval_to_typelist vs) Tvoid cc_default) *) + (* (INTERNAL: fd = Internal f1) *) + + Definition wf_sem_return {F V} (ge: Genv.t F V) (cp cp': compartment) (rv: eventval) := + (wf_eventval_pub ge rv) /\ + (not_ptr (eventval_to_val ge rv)) /\ + (Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall). + + (* wf_bt *) + + + (* wf_inv *) + Definition wf_inv_vload (ch: memory_chunk) (id: ident) (ofs: ptrofs) (v: eventval) e := + (wf_env e id). + + Definition wf_inv_vstore (ch: memory_chunk) (id: ident) (ofs: ptrofs) v e := + (wf_env e id) /\ (wf_eventval_env e v). + + Definition wf_inv_annot (str: string) (vs: list eventval) e := + (Forall (wf_eventval_env e) vs). + + Definition wf_inv_call_internal (cp cp': compartment) (id: ident) (vs: list eventval) e := + (e ! id = None) /\ (Forall (wf_eventval_env e) vs). + (* (CP1: cp = comp_of f) *) + + Definition wf_inv_return (cp cp': compartment) (rv: eventval) e (k: cont) := + (wf_eventval_env e rv) /\ + exists optid f' e' le' k', + (call_cont k = Kcall optid f' e' le' k') /\ + (cp = comp_of f'). + (* (fn_return f = eventval_to_type rv) *) + (* (CP1: cp' = comp_of f) *) + + (* TODO *) + +(** Events.v **) +(* (** External calls must commute with memory injections, *) +(* in the following sense. *) *) +(* ec_mem_inject: *) +(* forall ge1 ge2 c vargs m1 t vres m2 f m1' vargs', *) +(* symbols_inject f ge1 ge2 -> *) +(* sem ge1 c vargs m1 t vres m2 -> *) +(* Mem.inject f m1 m1' -> *) +(* Val.inject_list f vargs vargs' -> *) +(* exists f', exists vres', exists m2', *) +(* sem ge2 c vargs' m1' t vres' m2' *) +(* /\ Val.inject f' vres vres' *) +(* /\ Mem.inject f' m2 m2' *) +(* /\ Mem.unchanged_on (loc_unmapped f) m1 m2 *) +(* /\ Mem.unchanged_on (loc_out_of_reach f m1) m1' m2' *) +(* /\ inject_incr f f' *) +(* /\ inject_separated f f' m1 m1'; *) Lemma code_of_event_step_call_external p m @@ -846,38 +894,11 @@ Section Backtranslation. (sev :: nil) (Returnstate vres k m1 (rettype_of_type tres) (comp_of ef)). - Lemma code_of_event_step_return - ev - cp cp' rv - p f k e le m - ge - (GE: ge = globalenv p) - (EV: ev = Event_return cp' cp rv) - (* bt should ensure them *) - (WFRV1: wf_eventval_env e rv) - (WFRV2: wf_eventval_pub ge rv) - (* asm should ensure them *) - optid f' e' le' k' - (CONT: call_cont k = Kcall optid f' e' le' k') - (CP1: cp = comp_of f) - (CP2: cp' = comp_of f') - (NPTR: not_ptr (eventval_to_val ge rv)) - (CROSS: Genv.type_of_call ge (comp_of f') (comp_of f) = Genv.CrossCompartmentCall) - (* handle during proving *) - (RTTYP: fn_return f = eventval_to_type rv) - m' - (FREE: Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m') - : - Star (Clight.semantics1 p) - (State f (code_of_event ev) k e le m) - (ev :: nil) - (State f' Sskip k' e' (set_opttemp optid (eventval_to_val ge rv) le') m'). - End WELLFORMED. (* TODO *) - (* Axiom backtranslation: Policy.t -> split -> trace -> Clight.program * Clight.program. *) + (* Axiom backtranslation: Asm.program -> split -> trace -> Clight.program * Clight.program. *) (* Axiom backtranslation_correct: *) (* forall pol s t p C, *) (* backtranslation pol s t = (p, C) -> *) From 5cd629d5e71fc5a633184994b6ffb5c819038738 Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 19 Apr 2023 16:21:52 +0200 Subject: [PATCH 016/174] WIP: bt code gen --- security/Backtranslation.v | 237 ++++++++++++++++++++++++------------- 1 file changed, 153 insertions(+), 84 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index c4b5b302a6..257b518c24 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -7,8 +7,25 @@ Require Import Split. Require Import riscV.Asm. Require Import Ctypes Clight. -(* Record backtranslation_environment := *) -(* { local_counter: compartment -> ident }. *) + + +Lemma loc_out_of_reach_unchanged_content: + forall f b ofs m1 m1' m2' + (NOTMAP: forall b0 ofs0, not (f b0 = Some (b, ofs0))), (* f doesn't map anything to [b], i.e. the counter *) + Mem.perm m1' b ofs Cur Writable -> + 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). + - eapply Mem.perm_implies; eauto. constructor. +Qed. + +(* +forall b, b is the block of one of the counter -> + (forall b0 ofs, ~ (f b0 = Some (b, ofs))) + *) + Section Backtranslation. @@ -292,6 +309,60 @@ Section Backtranslation. End CONV. + Section CODEAUX. + + (* We extract function data: argument types, fn_return, rn_callconv from signature of Asm.function *) + (* Coreectness should follow from the semantics of Asm, especially 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 + (* will not appear in well formed traces *) + | AST.Tany32 => Tvoid + | AST.Tany64 => Tvoid + 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 => Tint I8 Signed noattr + | Tint8unsigned => Tint I8 Unsigned noattr + | Tint16signed => Tint I16 Signed noattr + | Tint16unsigned => Tint I16 Unsigned noattr + | AST.Tvoid => Tvoid + | Tret t => typ_to_type t + end. + + (* Wanted internal function data from signature *) + Definition fun_data : Type := (typelist * type * calling_convention). + Definition funs_data : Type := (PTree.tree fun_data). + + Definition from_sig_fun_data (sig: signature): fun_data := (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. + + End CODEAUX. + + Section CODE. (** converting trace to code **) @@ -310,6 +381,7 @@ Section Backtranslation. ) (list_eventval_to_typelist vs) (list_eventval_to_list_expr vs). + (* TODO: return type! *) 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). @@ -333,7 +405,10 @@ Section Backtranslation. Definition code_of_trace cp (t: trace): statement := Swhile (Econst_int Int.one (Tint I32 Signed noattr)) (switch cp (map code_of_event t) (Sreturn None)). + End CODE. + + Section CODEPROP. (* Properties *) Lemma ptr_of_id_ofs_eval @@ -597,6 +672,7 @@ Section Backtranslation. econstructor 1. Qed. + (* TODO: return type? *) Lemma code_of_event_step_call_start ev cp cp' id vs @@ -737,67 +813,7 @@ Section Backtranslation. econstructor 1. Qed. - End CODE. - - - Section PROJ. - (** Projection of the trace according to compartments **) - - Definition comp_of_event (e: event): option (compartment * compartment) := - match e with - | Event_call cp cp' id vs => Some (cp, cp') - | Event_return cp' cp v => Some (cp, cp') - | _ => None - end. - - (* Instance has_comp_event: has_comp event := *) - - Definition comp_proj_trace (cp: compartment) (t: trace): compartment * trace := - fold_right - (fun ev '(cp_now, sub) => match comp_of_event ev with - | Some (cp_curr, cp_next) => (cp_next, if (Pos.eqb cp_curr cp) then (ev :: sub) else sub) - | None => (cp_now, if (Pos.eqb cp_now cp) then (ev :: sub) else sub) - end) - (default_compartment, nil) t. - - Definition comp_subtrace (cp: compartment) (t: trace) := - snd (comp_proj_trace cp t). - - Definition code_of_subtrace cp t := - code_of_trace cp (comp_subtrace cp t). - - Definition codes_of_subtraces (cps: list compartment) t : PTree.t statement := - PTree_Properties.of_list (map (fun cp => (cp, code_of_subtrace cp t)) cps). - - Definition get_cps_from_policy (p: Policy.t): list compartment := - map fst (PTree.elements p.(Policy.policy_export)). - - End PROJ. - - - Section FROMASM. - (** Well-formed conditions for the trace, namely from the semantics of Asm **) - - Variable p: Asm.program. - Let ge := Genv.globalenv p. - - Definition wf_tr_vload ch (id: ident) (ofs: ptrofs) v := - exists rv, eventval_match ge v (type_of_chunk ch) rv. - - (* TODO: fix eventval_to_val *) - (* Definition wf_tr_vstore ch (id: ident) (ofs: ptrofs) v := *) - (* eventval_match ge v (type_of_chunk ch) (Val.load_result ch (eventval_to_val ge v)). *) - - Definition wf_tr_annot (str: string) (vs: list eventval) := True. - - (* TODO: fix *) - Definition wf_tr_call_start (cp cp': compartment) (id: ident) (vs: list eventval) := - (* (Forall not_ptr (list_eventval_to_list_val ge vs)) /\ *) - (Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) /\ - (exists l1, ((Policy.policy_import (Genv.genv_policy ge)) ! cp = Some l1) /\ (In (cp', id) l1)) /\ - (exists l2, ((Policy.policy_export (Genv.genv_policy ge)) ! cp' = Some l2) /\ (In id l2)). - - End FROMASM. + End CODEPROP. Section WELLFORMED. @@ -815,12 +831,12 @@ Section Backtranslation. Definition wf_sem_annot {F V} (ge: Genv.t F V) (str: string) (vs: list eventval) := (Forall (wf_eventval_pub ge) vs). - Definition wf_sem_call_internal {F V} {CF: has_comp F} (FD: F -> Prop) (ge: Genv.t F V) (cp cp': compartment) (id: ident) (vs: list eventval) := + Definition wf_sem_call_internal {F V} {CF: has_comp F} (FD: (list eventval) -> F -> Prop) (ge: Genv.t F V) (cp cp': compartment) (id: ident) (vs: list eventval) := (Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) /\ ((Forall (wf_eventval_pub ge) vs) /\ (Forall not_ptr (list_eventval_to_list_val ge vs))) /\ exists b, (Genv.find_symbol ge id = Some b) /\ (Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) /\ - (exists fd, (Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) /\ (cp' = comp_of fd) /\ (FD fd)). + (exists fd, (Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) /\ (cp' = comp_of fd) /\ (FD vs fd)). (* (TYPEF: type_of_fundef fd = Tfunction (list_eventval_to_typelist vs) Tvoid cc_default) *) (* (INTERNAL: fd = Internal f1) *) @@ -855,6 +871,24 @@ Section Backtranslation. (* (CP1: cp' = comp_of f) *) (* TODO *) + | step_return_1 : forall (f : function) (a : expr) (k : cont) (e : env) (le : temp_env) (m : mem) (v v' : val) (m' : mem), + eval_expr ge e (comp_of f) le m a v -> + Cop.sem_cast v (typeof a) (fn_return f) m = Some v' -> + Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m' -> + step ge function_entry (State f (Sreturn (Some a)) k e le m) E0 (Returnstate v' (call_cont k) m' (rettype_of_type (fn_return f)) (comp_of f)) + | step_returnstate : forall (v : val) (optid : option ident) (f : function) (e : env) (le : temp_env) (ty : rettype) (cp : compartment) (k : cont) (m : mem) (t : trace), + (Genv.type_of_call ge (comp_of f) cp = Genv.CrossCompartmentCall -> not_ptr v) -> + return_trace ge (comp_of f) cp v ty t -> step ge function_entry (Returnstate v (Kcall optid f e le k) m ty cp) t (State f Sskip k e (set_opttemp optid v le) m). +Inductive return_trace (F V : Type) (ge : Genv.t F V) : compartment -> compartment -> val -> rettype -> trace -> Prop := + return_trace_intra : forall (cp cp' : compartment) (v : val) (ty : rettype), Genv.type_of_call ge cp cp' <> Genv.CrossCompartmentCall -> return_trace ge cp cp' v ty E0 + | return_trace_cross : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype), + Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> eventval_match ge res (proj_rettype ty) v -> return_trace ge cp cp' v ty (Event_return cp cp' res :: nil). +Inductive eventval_match (ge : Senv.t) : eventval -> typ -> val -> Prop := + ev_match_int : forall i : int, eventval_match ge (EVint i) AST.Tint (Vint i) + | ev_match_long : forall i : int64, eventval_match ge (EVlong i) AST.Tlong (Vlong i) + | ev_match_float : forall f : Floats.float, eventval_match ge (EVfloat f) AST.Tfloat (Vfloat f) + | ev_match_single : forall f : Floats.float32, eventval_match ge (EVsingle f) Tsingle (Vsingle f) + | ev_match_ptr : forall (id : ident) (b : block) (ofs : ptrofs), Senv.public_symbol ge id = true -> Senv.find_symbol ge id = Some b -> eventval_match ge (EVptr_global id ofs) Tptr (Vptr b ofs). (** Events.v **) (* (** External calls must commute with memory injections, *) @@ -874,29 +908,64 @@ Section Backtranslation. (* /\ inject_incr f f' *) (* /\ inject_separated f f' m1 m1'; *) - Lemma code_of_event_step_call_external - p m - ge - (GE: ge = globalenv p) - (* bt should ensure them *) - fd k args ef targs tres cconv - (EXTERNAL: fd = External ef targs tres cconv) - (* asm should ensure them *) - sev - vres m1 - (SEM: external_call ef ge (call_comp k) args m (sev :: nil) vres m1) - (* handle during proving *) - sname sargs svr - (SYSEV: sev = Event_syscall sname sargs svr) - : - Star (Clight.semantics1 p) - (Callstate fd args k m) - (sev :: nil) - (Returnstate vres k m1 (rettype_of_type tres) (comp_of ef)). + (* Lemma code_of_event_step_call_external *) + (* p m *) + (* ge *) + (* (GE: ge = globalenv p) *) + (* (* bt should ensure them *) *) + (* fd k args ef targs tres cconv *) + (* (EXTERNAL: fd = External ef targs tres cconv) *) + (* (* asm should ensure them *) *) + (* sev *) + (* vres m1 *) + (* (SEM: external_call ef ge (call_comp k) args m (sev :: nil) vres m1) *) + (* (* handle during proving *) *) + (* sname sargs svr *) + (* (SYSEV: sev = Event_syscall sname sargs svr) *) + (* : *) + (* Star (Clight.semantics1 p) *) + (* (Callstate fd args k m) *) + (* (sev :: nil) *) + (* (Returnstate vres k m1 (rettype_of_type tres) (comp_of ef)). *) End WELLFORMED. + Section PROJ. + (** Projection of the trace according to compartments **) + + Definition comp_of_event (e: event): option (compartment * compartment) := + match e with + | Event_call cp cp' id vs => Some (cp, cp') + | Event_return cp' cp v => Some (cp, cp') + | _ => None + end. + + (* Instance has_comp_event: has_comp event := *) + + Definition comp_proj_trace (cp: compartment) (t: trace): compartment * trace := + fold_right + (fun ev '(cp_now, sub) => match comp_of_event ev with + | Some (cp_curr, cp_next) => (cp_next, if (Pos.eqb cp_curr cp) then (ev :: sub) else sub) + | None => (cp_now, if (Pos.eqb cp_now cp) then (ev :: sub) else sub) + end) + (default_compartment, nil) t. + + Definition comp_subtrace (cp: compartment) (t: trace) := + snd (comp_proj_trace cp t). + + Definition code_of_subtrace cp t := + code_of_trace cp (comp_subtrace cp t). + + Definition codes_of_subtraces (cps: list compartment) t : PTree.t statement := + PTree_Properties.of_list (map (fun cp => (cp, code_of_subtrace cp t)) cps). + + Definition get_cps_from_policy (p: Policy.t): list compartment := + map fst (PTree.elements p.(Policy.policy_export)). + + End PROJ. + + (* TODO *) (* Axiom backtranslation: Asm.program -> split -> trace -> Clight.program * Clight.program. *) (* Axiom backtranslation_correct: *) From bbabb22f39dc8360f4d5d098c311c57db49b664b Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 19 Apr 2023 17:17:36 +0200 Subject: [PATCH 017/174] WIP: defined code gen --- security/Backtranslation.v | 90 ++++++++++++++++++++++++++++++-------- 1 file changed, 72 insertions(+), 18 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 257b518c24..5a7f6e85b8 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -343,10 +343,13 @@ Section Backtranslation. end. (* Wanted internal function data from signature *) - Definition fun_data : Type := (typelist * type * calling_convention). + (* Definition fun_data : Type := (typelist * type * calling_convention). *) + 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 := (list_typ_to_typelist sig.(sig_args), rettype_to_type sig.(sig_res), sig.(sig_cc)). + (* Definition from_sig_fun_data (sig: signature): fun_data := (list_typ_to_typelist sig.(sig_args), rettype_to_type sig.(sig_res), sig.(sig_cc)). *) + 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). @@ -368,22 +371,28 @@ Section Backtranslation. (* converting functions *) 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). + Sbuiltin None (EF_vload ch) (dargs (from_extfun_fun_data (EF_vload ch))) (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) (Tcons (eventval_to_type v) Tnil)) ((ptr_of_id_ofs id ofs) :: (eventval_to_expr v) :: nil). + Sbuiltin None (EF_vstore ch) (dargs (from_extfun_fun_data (EF_vstore ch))) ((ptr_of_id_ofs id ofs) :: (eventval_to_expr v) :: nil). 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). - - (* TODO: return type! *) - 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). + let efa := (EF_annot + (Pos.of_nat (List.length (typlist_of_typelist (list_eventval_to_typelist vs)))) + str + (typlist_of_typelist (list_eventval_to_typelist vs)) + ) + in + Sbuiltin None efa (dargs (from_extfun_fun_data efa)) (list_eventval_to_list_expr vs). + + Definition code_of_call (fds: funs_data) (cp cp': compartment) (id: ident) (vs: list eventval) := + let '(targs, tret, cc) := match fds ! id with + | Some data => (dargs data, dret data, dcc data) + | None => (Tnil, Tvoid, cc_default) + end + in + Scall None (Evar id (Tfunction targs tret cc)) (list_eventval_to_list_expr vs). + (* Scall None (Evar id (Tfunction (list_eventval_to_typelist vs) Tvoid cc_default)) (list_eventval_to_list_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. @@ -391,23 +400,68 @@ Section Backtranslation. Definition code_of_return (cp cp': compartment) (v: eventval) := Sreturn (Some (eventval_to_expr v)). - Definition code_of_event (e: event): statement := + Definition code_of_event (fds: funs_data) (e: event): statement := match e with | 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_call cp cp' id vs => code_of_call fds cp cp' id vs | Event_syscall name vs v => code_of_syscall name vs v | Event_return cp cp' v => code_of_return cp cp' v end. (* A while(1)-loop with a big switch inside it *) - Definition code_of_trace cp (t: trace): statement := - Swhile (Econst_int Int.one (Tint I32 Signed noattr)) (switch cp (map code_of_event t) (Sreturn None)). + Definition code_of_trace (fds: funs_data) (t: trace) cnt: statement := + Swhile (Econst_int Int.one (Tint I32 Signed noattr)) (switch cnt (map (code_of_event fds) t) (Sreturn None)). End CODE. + (* Section CODE. *) + (* (** converting trace to code **) *) + + (* (* converting functions *) *) + (* 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) (Tcons (eventval_to_type v) Tnil)) ((ptr_of_id_ofs id ofs) :: (eventval_to_expr v) :: nil). *) + + (* 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). *) + + (* (* TODO: return type! *) *) + (* 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). *) + + (* (* 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_return (cp cp': compartment) (v: eventval) := *) + (* Sreturn (Some (eventval_to_expr v)). *) + + (* Definition code_of_event (e: event): statement := *) + (* match e with *) + (* | 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_syscall name vs v => code_of_syscall name vs v *) + (* | Event_return cp cp' v => code_of_return cp cp' v *) + (* end. *) + + (* (* A while(1)-loop with a big switch inside it *) *) + (* Definition code_of_trace cp (t: trace): statement := *) + (* Swhile (Econst_int Int.one (Tint I32 Signed noattr)) (switch cp (map code_of_event t) (Sreturn None)). *) + + (* End CODE. *) + + Section CODEPROP. (* Properties *) From 23a50515fe794be0f887bd5a0ee977d7a14acd4c Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 20 Apr 2023 11:41:17 +0200 Subject: [PATCH 018/174] WIP --- security/Backtranslation.v | 548 +++++++++++++++++++++++++++++++------ 1 file changed, 459 insertions(+), 89 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 5a7f6e85b8..3275917e10 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -464,6 +464,34 @@ Section Backtranslation. Section CODEPROP. (* Properties *) + Lemma eventval_match_transl + F V (ge: Genv.t F V) + 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_list_match_transl + F V (ge: Genv.t F V) + 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 typ_type_typ + F V (ge: Genv.t F V) + 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 ptr_of_id_ofs_eval id ofs e (ge: genv) b cp le m @@ -483,56 +511,6 @@ Section Backtranslation. erewrite Ptrofs.agree32_of_ints_eq; auto. apply Ptrofs.agree32_to_int; auto. Qed. - Lemma eventval_to_expr_match - (ge: genv) env cp le m - ev exp v ty - (WFENV: wf_eventval_env env ev) - (WFGE: wf_eventval_pub ge ev) - (CONV: eventval_to_expr ev = exp) - (EVAL: eval_expr ge env cp le m exp v) - (TYPE: typ_of_type (eventval_to_type ev) = ty) - : - eventval_match ge ev ty v. - Proof. - subst. destruct ev; simpl in *. - - inversion EVAL; subst; simpl in *; try constructor. inversion H. - - inversion EVAL; subst; simpl in *; try constructor. inversion H. - - inversion EVAL; subst; simpl in *; try constructor. inversion H. - - inversion EVAL; subst; simpl in *; try constructor. inversion H. - - unfold ptr_of_id_ofs in EVAL. destruct Archi.ptr64 eqn:ARCH. - + inversion EVAL; subst; simpl in *; try constructor. - 2:{ inversion H. } - inversion H5; subst; simpl in *. - 2:{ inversion H. } - clear H5. inversion H4; subst; simpl in *. - 2:{ inversion H. } - clear H4. inversion H2; subst; simpl. - { rewrite WFENV in H4. inversion H4. } - { inversion H6. - rewrite Ptrofs.mul_commut, Ptrofs.mul_one. - rewrite Ptrofs.add_zero_l. - replace (Ptrofs.of_int64 (Ptrofs.to_int64 i0)) with i0. - constructor; auto. - symmetry. apply Ptrofs.of_int64_to_int64. auto. - } - + inversion EVAL; subst; simpl in *; try constructor. - 2:{ inversion H. } - inversion H5; subst; simpl in *. - 2:{ inversion H. } - clear H5. inversion H4; subst; simpl in *. - 2:{ inversion H. } - clear H4. inversion H2; subst; simpl. - { rewrite WFENV in H4. inversion H4. } - { inversion H6. - rewrite Ptrofs.mul_commut, Ptrofs.mul_one. - rewrite Ptrofs.add_zero_l. - replace (Ptrofs.of_ints (Ptrofs.to_int i0)) with i0. - constructor; auto. - symmetry. apply Ptrofs.agree32_of_ints_eq; auto. - apply Ptrofs.agree32_to_int; auto. - } - Qed. - Lemma eventval_to_expr_val_eval (ge: genv) en cp temp m ev (WFENV: wf_eventval_env en ev) @@ -551,58 +529,43 @@ Section Backtranslation. erewrite Ptrofs.agree32_of_ints_eq; auto. apply Ptrofs.agree32_to_int; auto. Qed. - Lemma eventval_to_expr_val_match - (ge: genv) env - ev exp v ty - (WFENV: wf_eventval_env env ev) - (WFEV: wf_eventval_pub ge ev) - (CONV0: eventval_to_expr ev = exp) - (CONV1: eventval_to_val ge ev = v) - (TYPE: typ_of_type (eventval_to_type ev) = ty) + Lemma sem_cast_eventval_match + (ge: genv) v ty vv m + (WFEV: wf_eventval_ge ge v) + (EM: eventval_match ge v (typ_of_type (typ_to_type ty)) vv) : - eventval_match ge ev ty v. + Cop.sem_cast vv (typeof (eventval_to_expr v)) (typ_to_type ty) m = Some vv. Proof. - subst. eapply eventval_to_expr_match; eauto. eapply eventval_to_expr_val_eval; eauto. apply wf_eventval_pub_ge; auto. - Unshelve. exact default_compartment. exact (PTree.empty val). exact Mem.empty. + 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. } Qed. - Lemma sem_cast_eventval - (ge: genv) 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_eval - (ge: genv) en cp temp m evs + (ge: genv) en cp temp m evs tys (WFENV: Forall (wf_eventval_env en) evs) (WFGE: Forall (wf_eventval_ge ge) evs) + (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_eventval_to_typelist evs) (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. - move evs at top. revert ge en cp temp m WFENV WFGE. induction evs; intros; simpl in *. - constructor. + revert en cp temp m WFENV WFGE. + 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 *. inversion WFENV; clear WFENV; subst. inversion WFGE; clear WFGE; subst. + destruct tys; simpl in Heqtys2. congruence with Heqtys2. + inversion Heqtys2; clear Heqtys2; subst; simpl in *. econstructor; eauto. eapply eventval_to_expr_val_eval; eauto. - apply sem_cast_eventval; auto. + eapply sem_cast_eventval_match; eauto. Qed. - Lemma list_eventval_to_expr_val_match - (ge: genv) env - evs exps vs tys - (WFENV: Forall (wf_eventval_env env) evs) - (WFPUB: Forall (wf_eventval_pub ge) evs) - (CONV0: list_eventval_to_list_expr evs = exps) - (CONV1: list_eventval_to_list_val ge evs = vs) - (TYPE: list_eventval_to_typelist evs = tys) - : - eventval_list_match ge evs (typlist_of_typelist tys) vs. - Proof. - move evs at top. revert ge env exps vs tys WFENV WFPUB CONV0 CONV1 TYPE. - induction evs; intros; simpl in *; subst. constructor. - inversion WFENV; clear WFENV; subst. inversion WFPUB; clear WFPUB; subst. - econstructor; eauto. eapply eventval_to_expr_val_match; eauto. - Qed. + + Lemma code_of_event_step_vload @@ -870,6 +833,413 @@ Section Backtranslation. End CODEPROP. + (* Section CODEPROP. *) + (* (* Properties *) *) + (* Lemma ptr_of_id_ofs_eval *) + (* id ofs e (ge: genv) b cp le m *) + (* (GE1: wf_env e id) *) + (* (GE2: Genv.find_symbol ge id = Some b) *) + (* : *) + (* eval_expr ge e cp le m (ptr_of_id_ofs id ofs) (Vptr b ofs). *) + (* Proof. *) + (* 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 eventval_to_expr_match *) + (* (ge: genv) env cp le m *) + (* ev exp v ty *) + (* (WFENV: wf_eventval_env env ev) *) + (* (WFGE: wf_eventval_pub ge ev) *) + (* (CONV: eventval_to_expr ev = exp) *) + (* (EVAL: eval_expr ge env cp le m exp v) *) + (* (TYPE: typ_of_type (eventval_to_type ev) = ty) *) + (* : *) + (* eventval_match ge ev ty v. *) + (* Proof. *) + (* subst. destruct ev; simpl in *. *) + (* - inversion EVAL; subst; simpl in *; try constructor. inversion H. *) + (* - inversion EVAL; subst; simpl in *; try constructor. inversion H. *) + (* - inversion EVAL; subst; simpl in *; try constructor. inversion H. *) + (* - inversion EVAL; subst; simpl in *; try constructor. inversion H. *) + (* - unfold ptr_of_id_ofs in EVAL. destruct Archi.ptr64 eqn:ARCH. *) + (* + inversion EVAL; subst; simpl in *; try constructor. *) + (* 2:{ inversion H. } *) + (* inversion H5; subst; simpl in *. *) + (* 2:{ inversion H. } *) + (* clear H5. inversion H4; subst; simpl in *. *) + (* 2:{ inversion H. } *) + (* clear H4. inversion H2; subst; simpl. *) + (* { rewrite WFENV in H4. inversion H4. } *) + (* { inversion H6. *) + (* rewrite Ptrofs.mul_commut, Ptrofs.mul_one. *) + (* rewrite Ptrofs.add_zero_l. *) + (* replace (Ptrofs.of_int64 (Ptrofs.to_int64 i0)) with i0. *) + (* constructor; auto. *) + (* symmetry. apply Ptrofs.of_int64_to_int64. auto. *) + (* } *) + (* + inversion EVAL; subst; simpl in *; try constructor. *) + (* 2:{ inversion H. } *) + (* inversion H5; subst; simpl in *. *) + (* 2:{ inversion H. } *) + (* clear H5. inversion H4; subst; simpl in *. *) + (* 2:{ inversion H. } *) + (* clear H4. inversion H2; subst; simpl. *) + (* { rewrite WFENV in H4. inversion H4. } *) + (* { inversion H6. *) + (* rewrite Ptrofs.mul_commut, Ptrofs.mul_one. *) + (* rewrite Ptrofs.add_zero_l. *) + (* replace (Ptrofs.of_ints (Ptrofs.to_int i0)) with i0. *) + (* constructor; auto. *) + (* symmetry. apply Ptrofs.agree32_of_ints_eq; auto. *) + (* apply Ptrofs.agree32_to_int; auto. *) + (* } *) + (* Qed. *) + + (* Lemma eventval_to_expr_val_eval *) + (* (ge: genv) en cp temp m ev *) + (* (WFENV: wf_eventval_env en ev) *) + (* (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. *) + (* destruct WFGE as [b WFGE]. *) + (* rewrite WFGE. unfold ptr_of_id_ofs. destruct Archi.ptr64 eqn:ARCH. *) + (* - econstructor; try econstructor. eapply eval_Evar_global; eauto. *) + (* simpl. simpl_expr. rewrite Ptrofs.mul_commut, Ptrofs.mul_one. rewrite Ptrofs.add_zero_l. *) + (* rewrite Ptrofs.of_int64_to_int64; auto. *) + (* - econstructor; try econstructor. eapply eval_Evar_global; eauto. *) + (* 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 eventval_to_expr_val_match *) + (* (ge: genv) env *) + (* ev exp v ty *) + (* (WFENV: wf_eventval_env env ev) *) + (* (WFEV: wf_eventval_pub ge ev) *) + (* (CONV0: eventval_to_expr ev = exp) *) + (* (CONV1: eventval_to_val ge ev = v) *) + (* (TYPE: typ_of_type (eventval_to_type ev) = ty) *) + (* : *) + (* eventval_match ge ev ty v. *) + (* Proof. *) + (* subst. eapply eventval_to_expr_match; eauto. eapply eventval_to_expr_val_eval; eauto. apply wf_eventval_pub_ge; auto. *) + (* Unshelve. exact default_compartment. exact (PTree.empty val). exact Mem.empty. *) + (* Qed. *) + + (* Lemma sem_cast_eventval *) + (* (ge: genv) 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_eval *) + (* (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 list_eventval_to_expr_val_match *) + (* (ge: genv) env *) + (* evs exps vs tys *) + (* (WFENV: Forall (wf_eventval_env env) evs) *) + (* (WFPUB: Forall (wf_eventval_pub ge) evs) *) + (* (CONV0: list_eventval_to_list_expr evs = exps) *) + (* (CONV1: list_eventval_to_list_val ge evs = vs) *) + (* (TYPE: list_eventval_to_typelist evs = tys) *) + (* : *) + (* eventval_list_match ge evs (typlist_of_typelist tys) vs. *) + (* Proof. *) + (* move evs at top. revert ge env exps vs tys WFENV WFPUB CONV0 CONV1 TYPE. *) + (* induction evs; intros; simpl in *; subst. constructor. *) + (* inversion WFENV; clear WFENV; subst. inversion WFPUB; clear WFPUB; subst. *) + (* econstructor; eauto. eapply eventval_to_expr_val_match; eauto. *) + (* Qed. *) + + + (* Lemma code_of_event_step_vload *) + (* ev *) + (* ch id ofs v *) + (* p f k e le m *) + (* (EV: ev = Event_vload ch id ofs v) *) + (* (* bt should ensure them *) *) + (* (WFENV: wf_env e id) *) + (* b *) + (* (VOL: Senv.block_is_volatile (globalenv p) b = true) *) + (* (GE: Genv.find_symbol (globalenv p) id = Some b) *) + (* (* asm should ensure them *) *) + (* rv *) + (* (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) rv) *) + (* : *) + (* Star (Clight.semantics1 p) *) + (* (State f (code_of_event ev) k e le m) *) + (* (ev :: nil) *) + (* (State f Sskip k e le m). *) + (* Proof. *) + (* subst; simpl in *. unfold code_of_vload. *) + (* destruct Archi.ptr64 eqn:ARCH. *) + (* - econstructor 2. *) + (* 3:{ rewrite E0_right. reflexivity. } *) + (* { eapply step_builtin. *) + (* { econstructor; eauto. 3: econstructor. *) + (* - eapply ptr_of_id_ofs_eval; eauto. *) + (* - unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. *) + (* } *) + (* repeat econstructor; eauto. *) + (* } *) + (* econstructor 1. *) + (* - econstructor 2. *) + (* 3:{ rewrite E0_right. reflexivity. } *) + (* { eapply step_builtin. *) + (* { econstructor; eauto. 3: econstructor. *) + (* - eapply ptr_of_id_ofs_eval; eauto. *) + (* - unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. *) + (* } *) + (* repeat econstructor; eauto. *) + (* } *) + (* econstructor 1. *) + (* Qed. *) + + (* Lemma code_of_event_step_vstore *) + (* ev *) + (* ch id ofs v *) + (* p f k e le m *) + (* (EV: ev = Event_vstore ch id ofs v) *) + (* (* bt should ensure them *) *) + (* (WFENV: wf_env e id) *) + (* b *) + (* (VOL: Senv.block_is_volatile (globalenv p) b = true) *) + (* (GE: Genv.find_symbol (globalenv p) id = Some b) *) + (* (* asm should ensure them *) *) + (* (WFSV1: wf_eventval_env e v) *) + (* (WFSV2: wf_eventval_ge (globalenv p) v) *) + (* (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) (Val.load_result ch (eventval_to_val (globalenv p) v))) *) + (* : *) + (* Star (Clight.semantics1 p) *) + (* (State f (code_of_event ev) k e le m) *) + (* (ev :: nil) *) + (* (State f Sskip k e le m). *) + (* Proof. *) + (* subst; simpl in *. unfold code_of_vstore. *) + (* destruct Archi.ptr64 eqn:ARCH. *) + (* - econstructor 2. *) + (* 3:{ rewrite E0_right. reflexivity. } *) + (* { eapply step_builtin. *) + (* { econstructor; eauto. *) + (* { eapply ptr_of_id_ofs_eval; eauto. } *) + (* { unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. } *) + (* econstructor; eauto. 3: econstructor. *) + (* { eapply eventval_to_expr_val_eval; auto. } *) + (* { apply sem_cast_eventval; auto. } *) + (* } *) + (* simpl. *) + (* repeat econstructor; eauto. *) + (* } *) + (* econstructor 1. *) + (* - econstructor 2. *) + (* 3:{ rewrite E0_right. reflexivity. } *) + (* { eapply step_builtin. *) + (* { econstructor; eauto. *) + (* { eapply ptr_of_id_ofs_eval; eauto. } *) + (* { unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. } *) + (* econstructor; eauto. 3: econstructor. *) + (* { eapply eventval_to_expr_val_eval; auto. } *) + (* { apply sem_cast_eventval; auto. } *) + (* } *) + (* simpl. *) + (* repeat econstructor; eauto. *) + (* } *) + (* econstructor 1. *) + (* Qed. *) + + (* Lemma code_of_event_step_annot *) + (* ev *) + (* str vs *) + (* p f k e le m *) + (* (EV: ev = Event_annot str vs) *) + (* (* bt should ensure them *) *) + (* (WFENV: Forall (wf_eventval_env e) vs) *) + (* (WFPUB: Forall (wf_eventval_pub (globalenv p)) vs) *) + (* (* asm should ensure them *) *) + (* : *) + (* Star (Clight.semantics1 p) *) + (* (State f (code_of_event ev) k e le m) *) + (* (ev :: nil) *) + (* (State f Sskip k e le m). *) + (* Proof. *) + (* subst; simpl in *. unfold code_of_annot. *) + (* econstructor 2. *) + (* 3:{ rewrite E0_right. reflexivity. } *) + (* { eapply step_builtin. *) + (* { eapply list_eventval_to_expr_val_eval; auto. *) + (* eapply Forall_impl. 2: eauto. intros. apply wf_eventval_pub_ge; auto. } *) + (* repeat econstructor; eauto. eapply list_eventval_to_expr_val_match; eauto. *) + (* } *) + (* econstructor 1. *) + (* Qed. *) + + (* (* TODO: return type? *) *) + (* Lemma code_of_event_step_call_start *) + (* ev *) + (* cp cp' id vs *) + (* p f k e le m *) + (* ge *) + (* (GE: ge = globalenv p) *) + (* (EV: ev = Event_call cp cp' id vs) *) + (* (* bt should ensure them *) *) + (* (GLOB: e ! id = None) *) + (* b *) + (* (FINDB: Genv.find_symbol ge id = Some b) *) + (* fd *) + (* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) *) + (* (TYPEF: type_of_fundef fd = Tfunction (list_eventval_to_typelist vs) Tvoid cc_default) *) + (* (WFARGS1: Forall (wf_eventval_env e) vs) *) + (* (WFARGS2: Forall (wf_eventval_pub ge) vs) *) + (* (* asm should ensure them *) *) + (* (CP1: cp = comp_of f) *) + (* (CP2: cp' = comp_of fd) *) + (* (NPTR: Forall not_ptr (list_eventval_to_list_val ge vs)) *) + (* (CROSS: Genv.type_of_call ge (comp_of f) (comp_of fd) = Genv.CrossCompartmentCall) *) + (* (ALLOW: Genv.allowed_cross_call ge (comp_of f) (Vptr b Ptrofs.zero)) *) + (* : *) + (* Star (Clight.semantics1 p) *) + (* (State f (code_of_event ev) k e le m) *) + (* (ev :: nil) *) + (* (Callstate fd (list_eventval_to_list_val ge vs) (Kcall None f e le k) m). *) + (* Proof. *) + (* subst; simpl. unfold code_of_call. *) + (* econstructor 2. *) + (* 3:{ rewrite E0_right. reflexivity. } *) + (* { eapply step_call; simpl; eauto. *) + (* { eapply eval_Elvalue. *) + (* - eapply eval_Evar_global; eauto. *) + (* - eapply deref_loc_reference. auto. *) + (* } *) + (* { eapply list_eventval_to_expr_val_eval; auto. *) + (* eapply Forall_impl. 2: eauto. intros. apply wf_eventval_pub_ge; auto. } *) + (* red; auto. *) + (* unfold Genv.find_comp. setoid_rewrite FINDF. *) + (* eapply call_trace_cross; eauto. apply Genv.find_invert_symbol; auto. *) + (* eapply (list_eventval_to_expr_val_match (globalenv p)); eauto. *) + (* } *) + (* econstructor 1. *) + (* Qed. *) + + (* Lemma code_of_event_step_call_internal *) + (* p f k e le m *) + (* ge *) + (* (GE: ge = globalenv p) *) + (* (* bt should ensure them *) *) + (* fd args f1 *) + (* (INTERNAL: fd = Internal f1) *) + (* (* asm should ensure them *) *) + (* (* handle during proving *) *) + (* e1 le1 m1 *) + (* (ENTRY: function_entry1 ge f1 args m e1 le1 m1) *) + (* : *) + (* Star (Clight.semantics1 p) *) + (* (Callstate fd args (Kcall None f e le k) m) *) + (* nil *) + (* (State f1 (fn_body f1) (Kcall None f e le k) e1 le1 m1). *) + (* Proof. *) + (* subst; simpl. *) + (* econstructor 2. *) + (* 3:{ rewrite E0_right. reflexivity. } *) + (* { eapply step_internal_function; eauto. } *) + (* econstructor 1. *) + (* Qed. *) + + (* Lemma code_of_event_step_call_external *) + (* p m *) + (* ge *) + (* (GE: ge = globalenv p) *) + (* (* bt should ensure them *) *) + (* fd k args ef targs tres cconv *) + (* (EXTERNAL: fd = External ef targs tres cconv) *) + (* (* asm should ensure them *) *) + (* sev *) + (* vres m1 *) + (* (SEM: external_call ef ge (call_comp k) args m (sev :: nil) vres m1) *) + (* (* handle during proving *) *) + (* sname sargs svr *) + (* (SYSEV: sev = Event_syscall sname sargs svr) *) + (* : *) + (* Star (Clight.semantics1 p) *) + (* (Callstate fd args k m) *) + (* (sev :: nil) *) + (* (Returnstate vres k m1 (rettype_of_type tres) (comp_of ef)). *) + (* Proof. *) + (* subst; simpl. *) + (* econstructor 2. *) + (* 3:{ rewrite E0_right. reflexivity. } *) + (* { eapply step_external_function; eauto. } *) + (* econstructor 1. *) + (* Qed. *) + + (* Lemma code_of_event_step_return *) + (* ev *) + (* cp cp' rv *) + (* p f k e le m *) + (* ge *) + (* (GE: ge = globalenv p) *) + (* (EV: ev = Event_return cp' cp rv) *) + (* (* bt should ensure them *) *) + (* (WFRV1: wf_eventval_env e rv) *) + (* (WFRV2: wf_eventval_pub ge rv) *) + (* (RTTYP: fn_return f = eventval_to_type rv) *) + (* (* asm should ensure them *) *) + (* optid f' e' le' k' *) + (* (CONT: call_cont k = Kcall optid f' e' le' k') *) + (* (CP1: cp = comp_of f) *) + (* (CP2: cp' = comp_of f') *) + (* (NPTR: not_ptr (eventval_to_val ge rv)) *) + (* (CROSS: Genv.type_of_call ge (comp_of f') (comp_of f) = Genv.CrossCompartmentCall) *) + (* (* handle during proving *) *) + (* m' *) + (* (FREE: Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m') *) + (* : *) + (* Star (Clight.semantics1 p) *) + (* (State f (code_of_event ev) k e le m) *) + (* (ev :: nil) *) + (* (State f' Sskip k' e' (set_opttemp optid (eventval_to_val ge rv) le') m'). *) + (* Proof. *) + (* subst; simpl. unfold code_of_return. *) + (* econstructor 2. *) + (* 3:{ rewrite E0_left. reflexivity. } *) + (* { eapply step_return_1; simpl; eauto. *) + (* { eapply eventval_to_expr_val_eval; auto. apply wf_eventval_pub_ge; auto. } *) + (* { rewrite RTTYP. eapply sem_cast_eventval; auto. eapply wf_eventval_pub_ge; eauto. } *) + (* } *) + (* econstructor 2. *) + (* 3:{ rewrite E0_right. reflexivity. } *) + (* { rewrite CONT. eapply step_returnstate; auto. *) + (* econstructor 2; auto. rewrite RTTYP. eapply eventval_to_expr_val_match; eauto. *) + (* clear. destruct rv; simpl; auto. *) + (* } *) + (* econstructor 1. *) + (* Qed. *) + + (* End CODEPROP. *) + + Section WELLFORMED. (* wf_sem *) From 8f52c1f400122b7fcf71960a70f1f3529a55affe Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 20 Apr 2023 12:06:05 +0200 Subject: [PATCH 019/174] WIP --- security/Backtranslation.v | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 3275917e10..2d2953a0de 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -363,6 +363,17 @@ Section Backtranslation. 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 _ tps tr cc => mkfundata tps tr cc 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. @@ -565,20 +576,16 @@ Section Backtranslation. Qed. - - - + (* TODO *) Lemma code_of_event_step_vload ev ch id ofs v p f k e le m (EV: ev = Event_vload ch id ofs v) - (* bt should ensure them *) (WFENV: wf_env e id) b (VOL: Senv.block_is_volatile (globalenv p) b = true) (GE: Genv.find_symbol (globalenv p) id = Some b) - (* asm should ensure them *) rv (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) rv) : From 57b202639cae948aabdad8a7bbb3b44293b86c32 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 20 Apr 2023 16:44:03 +0200 Subject: [PATCH 020/174] WIP --- security/Backtranslation.v | 197 +++++++++++++++++++++---------------- 1 file changed, 114 insertions(+), 83 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 2d2953a0de..a1298a9304 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -446,7 +446,6 @@ Section Backtranslation. (* ) (list_eventval_to_typelist vs) *) (* (list_eventval_to_list_expr vs). *) - (* (* TODO: return type! *) *) (* 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). *) @@ -474,6 +473,9 @@ Section Backtranslation. Section CODEPROP. + + Let cgenv := Genv.t fundef type. + (* Properties *) Lemma eventval_match_transl F V (ge: Genv.t F V) @@ -486,6 +488,14 @@ Section Backtranslation. setoid_rewrite H0. unfold Tptr in *. destruct Archi.ptr64; auto. Qed. + Lemma eventval_match_wf_eventval_ge + F V (ge: Genv.t F V) + ev ty v + (EM: eventval_match ge ev ty v) + : + wf_eventval_ge ge ev. + Proof. inversion EM; subst; simpl; eauto. Qed. + Lemma eventval_list_match_transl F V (ge: Genv.t F V) evs tys vs @@ -541,8 +551,7 @@ Section Backtranslation. Qed. Lemma sem_cast_eventval_match - (ge: genv) v ty vv m - (WFEV: wf_eventval_ge ge v) + (ge: cgenv) 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. @@ -558,31 +567,72 @@ Section Backtranslation. Lemma list_eventval_to_expr_val_eval (ge: genv) en cp temp m evs tys (WFENV: Forall (wf_eventval_env en) evs) - (WFGE: Forall (wf_eventval_ge ge) evs) (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 WFGE. + 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 *. - inversion WFENV; clear WFENV; subst. inversion WFGE; clear WFGE; subst. + inversion WFENV; clear WFENV; subst. 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 + F V (ge: Genv.t F V) + 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 + F V (ge: Genv.t F V) + 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. + - (* TODO *) Lemma code_of_event_step_vload ev ch id ofs v p f k e le m (EV: ev = Event_vload ch id ofs v) + (* bt_wf *) (WFENV: wf_env e id) + (* from_asm *) b (VOL: Senv.block_is_volatile (globalenv p) b = true) (GE: Genv.find_symbol (globalenv p) id = Some b) @@ -590,32 +640,23 @@ Section Backtranslation. (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) rv) : Star (Clight.semantics1 p) - (State f (code_of_event ev) k e le m) + (State f (code_of_event (from_cl_funs_data p) ev) k e le m) (ev :: nil) (State f Sskip k e le m). Proof. - subst; simpl in *. unfold code_of_vload. - destruct Archi.ptr64 eqn:ARCH. - - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_builtin. - { econstructor; eauto. 3: econstructor. - - eapply ptr_of_id_ofs_eval; eauto. - - unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. - } - repeat econstructor; eauto. - } - econstructor 1. - - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_builtin. - { econstructor; eauto. 3: econstructor. - - eapply ptr_of_id_ofs_eval; eauto. - - unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. - } - repeat econstructor; eauto. + subst; simpl in *. unfold code_of_vload. simpl. + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_builtin. + { econstructor; eauto. 3: econstructor. + - eapply ptr_of_id_ofs_eval; eauto. + - destruct Archi.ptr64 eqn:ARCH. + + unfold ptr_of_id_ofs, Tptr. rewrite ARCH. simpl. unfold Cop.sem_cast. simpl. rewrite ARCH. eauto. + + unfold ptr_of_id_ofs, Tptr. rewrite ARCH. simpl. unfold Cop.sem_cast. simpl. rewrite ARCH. eauto. } - econstructor 1. + repeat econstructor; eauto. + } + econstructor 1. Qed. Lemma code_of_event_step_vstore @@ -623,51 +664,39 @@ Section Backtranslation. ch id ofs v p f k e le m (EV: ev = Event_vstore ch id ofs v) - (* bt should ensure them *) + (* bt_wf *) (WFENV: wf_env e id) + (WFSV1: wf_eventval_env e v) + (* from_asm *) b (VOL: Senv.block_is_volatile (globalenv p) b = true) (GE: Genv.find_symbol (globalenv p) id = Some b) - (* asm should ensure them *) - (WFSV1: wf_eventval_env e v) - (WFSV2: wf_eventval_ge (globalenv p) v) - (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) (Val.load_result ch (eventval_to_val (globalenv p) v))) + vv + (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) (Val.load_result ch vv)) : Star (Clight.semantics1 p) - (State f (code_of_event ev) k e le m) + (State f (code_of_event (from_cl_funs_data p) ev) k e le m) (ev :: nil) (State f Sskip k e le m). Proof. + apply val_load_result_aux in MATCH. subst; simpl in *. unfold code_of_vstore. - destruct Archi.ptr64 eqn:ARCH. - - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_builtin. - { econstructor; eauto. - { eapply ptr_of_id_ofs_eval; eauto. } - { unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. } - econstructor; eauto. 3: econstructor. - { eapply eventval_to_expr_val_eval; auto. } - { apply sem_cast_eventval; auto. } - } - simpl. - repeat econstructor; eauto. - } - econstructor 1. - - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_builtin. - { econstructor; eauto. - { eapply ptr_of_id_ofs_eval; eauto. } - { unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. } - econstructor; eauto. 3: econstructor. - { eapply eventval_to_expr_val_eval; auto. } - { apply sem_cast_eventval; auto. } + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_builtin. + { econstructor; eauto. + { eapply ptr_of_id_ofs_eval; eauto. } + { destruct Archi.ptr64 eqn:ARCH. + - unfold ptr_of_id_ofs, Tptr. rewrite ARCH; simpl. unfold Cop.sem_cast. simpl. rewrite ARCH. eauto. + - unfold ptr_of_id_ofs, Tptr. rewrite ARCH; simpl. unfold Cop.sem_cast. simpl. rewrite ARCH. eauto. } - simpl. - repeat econstructor; eauto. + econstructor; eauto. 3: econstructor. + { eapply eventval_to_expr_val_eval; auto. eapply eventval_match_wf_eventval_ge; eauto. } + { eapply sem_cast_eventval_match; eauto. eapply eventval_match_transl. eauto. } } - econstructor 1. + simpl. repeat econstructor; eauto. + } + econstructor 1. Qed. Lemma code_of_event_step_annot @@ -675,57 +704,59 @@ Section Backtranslation. str vs p f k e le m (EV: ev = Event_annot str vs) - (* bt should ensure them *) + (* bt_wf *) (WFENV: Forall (wf_eventval_env e) vs) - (WFPUB: Forall (wf_eventval_pub (globalenv p)) vs) - (* asm should ensure them *) + (* from_asm *) + targs vargs + (ESM: eventval_list_match (globalenv p) vs targs vargs) : Star (Clight.semantics1 p) - (State f (code_of_event ev) k e le m) + (State f (code_of_event (from_cl_funs_data p) ev) k e le m) (ev :: nil) (State f Sskip k e le m). Proof. subst; simpl in *. unfold code_of_annot. econstructor 2. 3:{ rewrite E0_right. reflexivity. } - { eapply step_builtin. - { eapply list_eventval_to_expr_val_eval; auto. - eapply Forall_impl. 2: eauto. intros. apply wf_eventval_pub_ge; auto. } - repeat econstructor; eauto. eapply list_eventval_to_expr_val_match; eauto. + { eapply step_builtin; simpl. + { eapply list_eventval_to_expr_val_eval; auto. eapply eventval_list_match_transl. eapply list_eventval_match_eventval_to_type; eauto. } + { repeat econstructor; eauto. eapply list_eventval_match_eventval_to_type. eapply eventval_list_match_transl; eauto. } } econstructor 1. Qed. - (* TODO: return type? *) Lemma code_of_event_step_call_start ev cp cp' id vs p f k e le m - ge + ge data (GE: ge = globalenv p) (EV: ev = Event_call cp cp' id vs) - (* bt should ensure them *) + (FDATA: (from_cl_funs_data p) ! id = Some data) + (* bt_wf *) (GLOB: e ! id = None) + (WFARGS1: Forall (wf_eventval_env e) vs) + (* from_asm *) b (FINDB: Genv.find_symbol ge id = Some b) fd (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (TYPEF: type_of_fundef fd = Tfunction (list_eventval_to_typelist vs) Tvoid cc_default) - (WFARGS1: Forall (wf_eventval_env e) vs) - (WFARGS2: Forall (wf_eventval_pub ge) vs) - (* asm should ensure them *) + (TYPEF: type_of_fundef fd = Tfunction data.(dargs) data.(dret) data.(dcc)) (CP1: cp = comp_of f) (CP2: cp' = comp_of fd) - (NPTR: Forall not_ptr (list_eventval_to_list_val ge vs)) (CROSS: Genv.type_of_call ge (comp_of f) (comp_of fd) = Genv.CrossCompartmentCall) + (NPTR: Forall not_ptr (list_eventval_to_list_val ge vs)) (ALLOW: Genv.allowed_cross_call ge (comp_of f) (Vptr b Ptrofs.zero)) + some_sig_args some_vals + (ESM: eventval_list_match ge vs some_sig_args some_vals) + (SIGARGS: data.(dargs) = (list_typ_to_typelist some_sig_args)) : Star (Clight.semantics1 p) - (State f (code_of_event ev) k e le m) + (State f (code_of_event (from_cl_funs_data p) ev) k e le m) (ev :: nil) (Callstate fd (list_eventval_to_list_val ge vs) (Kcall None f e le k) m). Proof. - subst; simpl. unfold code_of_call. + subst; simpl. unfold code_of_call. rewrite FDATA. econstructor 2. 3:{ rewrite E0_right. reflexivity. } { eapply step_call; simpl; eauto. @@ -733,16 +764,16 @@ Section Backtranslation. - eapply eval_Evar_global; eauto. - eapply deref_loc_reference. auto. } - { eapply list_eventval_to_expr_val_eval; auto. - eapply Forall_impl. 2: eauto. intros. apply wf_eventval_pub_ge; auto. } + { rewrite SIGARGS. apply list_eventval_to_expr_val_eval; auto. eapply eventval_list_match_transl. eauto. } red; auto. unfold Genv.find_comp. setoid_rewrite FINDF. eapply call_trace_cross; eauto. apply Genv.find_invert_symbol; auto. - eapply (list_eventval_to_expr_val_match (globalenv p)); eauto. + rewrite SIGARGS. eapply eventval_list_match_transl; eauto. } econstructor 1. Qed. + (* TODO *) Lemma code_of_event_step_call_internal p f k e le m ge From b656d24e2b7f899793c124f25a34bfa3eb16b875 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 20 Apr 2023 17:58:24 +0200 Subject: [PATCH 021/174] WIP --- security/Backtranslation.v | 193 ++++++++++++++++++++++++++----------- 1 file changed, 136 insertions(+), 57 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index a1298a9304..12f9add1af 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -9,22 +9,81 @@ Require Import Ctypes Clight. -Lemma loc_out_of_reach_unchanged_content: - forall f b ofs m1 m1' m2' - (NOTMAP: forall b0 ofs0, not (f b0 = Some (b, ofs0))), (* f doesn't map anything to [b], i.e. the counter *) - Mem.perm m1' b ofs Cur Writable -> - 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). - - eapply Mem.perm_implies; eauto. constructor. -Qed. - -(* +Section AUX. + + (* 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.perm m1' b ofs Cur Writable -> *) + 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). + (* eapply Mem.perm_implies; eauto. constructor. *) + 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. + + (* Record unchanged_on (P : block -> Z -> Prop) (m_before m_after : mem) : Prop := mk_unchanged_on *) + (* { unchanged_on_nextblock : Ple (Mem.nextblock m_before) (Mem.nextblock m_after); *) + (* unchanged_on_perm : forall (b : block) (ofs : Z) (k : perm_kind) (p : permission), P b ofs -> Mem.valid_block m_before b -> Mem.perm m_before b ofs k p <-> Mem.perm m_after b ofs k p; *) + (* unchanged_on_contents : forall (b : block) (ofs : Z), P b ofs -> Mem.perm m_before b ofs Cur Readable -> ZMap.get ofs (Mem.mem_contents m_after) !! b = ZMap.get ofs (Mem.mem_contents m_before) !! b; *) + (* unchanged_on_own : forall (b : block) (cp : option compartment), Mem.valid_block m_before b -> Mem.can_access_block m_before b cp <-> Mem.can_access_block m_after b cp }. *) + + 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. + + (* forall b, b is the block of one of the counter -> (forall b0 ofs, ~ (f b0 = Some (b, ofs))) - *) + *) + + (* (** External calls must commute with memory injections, *) + (* in the following sense. *) *) + (* ec_mem_inject: *) + (* forall ge1 ge2 c vargs m1 t vres m2 f m1' vargs', *) + (* symbols_inject f ge1 ge2 -> *) + (* sem ge1 c vargs m1 t vres m2 -> *) + (* Mem.inject f m1 m1' -> *) + (* Val.inject_list f vargs vargs' -> *) + (* exists f', exists vres', exists m2', *) + (* sem ge2 c vargs' m1' t vres' m2' *) + (* /\ Val.inject f' vres vres' *) + (* /\ Mem.inject f' m2 m2' *) + (* /\ Mem.unchanged_on (loc_unmapped f) m1 m2 *) + (* /\ Mem.unchanged_on (loc_out_of_reach f m1) m1' m2' *) + (* /\ inject_incr f f' *) + (* /\ inject_separated f f' m1 m1'; *) + +End AUX. Section Backtranslation. @@ -488,6 +547,14 @@ Section Backtranslation. setoid_rewrite H0. unfold Tptr in *. destruct Archi.ptr64; auto. Qed. + Lemma eventval_match_eventval_to_val + F V (ge: Genv.t F V) + 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_match_wf_eventval_ge F V (ge: Genv.t F V) ev ty v @@ -624,7 +691,19 @@ Section Backtranslation. rewrite H3, H. rewrite H0. rewrite val_load_result_idem. auto. Qed. + Lemma eventval_match_proj_rettype + F V (ge: Genv.t F V) + 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. + + (* Step lemmas *) Lemma code_of_event_step_vload ev ch id ofs v @@ -773,6 +852,49 @@ Section Backtranslation. econstructor 1. Qed. + Lemma code_of_event_step_return + ev + cp cp' rv + p f k e le m + ge + (GE: ge = globalenv p) + (EV: ev = Event_return cp' cp rv) + (* bt should ensure them *) + (WFRV1: wf_eventval_env e rv) + (* asm should ensure them *) + (NPTR: not_ptr (eventval_to_val ge rv)) + some_sig_ret some_val + (EM: eventval_match ge rv some_sig_ret some_val) + (RTTYP: fn_return f = typ_to_type some_sig_ret) + (* handle during proving *) + optid f' e' le' k' + (CONT: call_cont k = Kcall optid f' e' le' k') + (CP1: cp = comp_of f) + (CP2: cp' = comp_of f') + (CROSS: Genv.type_of_call ge (comp_of f') (comp_of f) = Genv.CrossCompartmentCall) + m' + (FREE: Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m') + : + Star (Clight.semantics1 p) + (State f (code_of_event (from_cl_funs_data p) ev) k e le m) + (ev :: nil) + (State f' Sskip k' e' (set_opttemp optid (eventval_to_val ge rv) le') m'). + Proof. + subst; simpl. unfold code_of_return. + econstructor 2. + 3:{ rewrite E0_left. reflexivity. } + { eapply step_return_1; simpl; eauto. + { eapply eventval_to_expr_val_eval; auto. eapply eventval_match_wf_eventval_ge; eauto. } + { rewrite RTTYP. eapply sem_cast_eventval_match. eapply eventval_match_transl; eauto. } + } + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { rewrite CONT. eapply step_returnstate; auto. + econstructor 2; auto. rewrite RTTYP. apply eventval_match_proj_rettype. erewrite eventval_match_eventval_to_val; eauto. + } + econstructor 1. + Qed. + (* TODO *) Lemma code_of_event_step_call_internal p f k e le m @@ -825,49 +947,6 @@ Section Backtranslation. econstructor 1. Qed. - Lemma code_of_event_step_return - ev - cp cp' rv - p f k e le m - ge - (GE: ge = globalenv p) - (EV: ev = Event_return cp' cp rv) - (* bt should ensure them *) - (WFRV1: wf_eventval_env e rv) - (WFRV2: wf_eventval_pub ge rv) - (RTTYP: fn_return f = eventval_to_type rv) - (* asm should ensure them *) - optid f' e' le' k' - (CONT: call_cont k = Kcall optid f' e' le' k') - (CP1: cp = comp_of f) - (CP2: cp' = comp_of f') - (NPTR: not_ptr (eventval_to_val ge rv)) - (CROSS: Genv.type_of_call ge (comp_of f') (comp_of f) = Genv.CrossCompartmentCall) - (* handle during proving *) - m' - (FREE: Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m') - : - Star (Clight.semantics1 p) - (State f (code_of_event ev) k e le m) - (ev :: nil) - (State f' Sskip k' e' (set_opttemp optid (eventval_to_val ge rv) le') m'). - Proof. - subst; simpl. unfold code_of_return. - econstructor 2. - 3:{ rewrite E0_left. reflexivity. } - { eapply step_return_1; simpl; eauto. - { eapply eventval_to_expr_val_eval; auto. apply wf_eventval_pub_ge; auto. } - { rewrite RTTYP. eapply sem_cast_eventval; auto. eapply wf_eventval_pub_ge; eauto. } - } - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { rewrite CONT. eapply step_returnstate; auto. - econstructor 2; auto. rewrite RTTYP. eapply eventval_to_expr_val_match; eauto. - clear. destruct rv; simpl; auto. - } - econstructor 1. - Qed. - End CODEPROP. From d928562f64e6a63adc6e7d981e425661dedec554 Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 21 Apr 2023 13:07:50 +0200 Subject: [PATCH 022/174] WIP --- security/Backtranslation.v | 599 ++++++------------------------------- 1 file changed, 94 insertions(+), 505 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 12f9add1af..9f716033c9 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -487,50 +487,6 @@ Section Backtranslation. End CODE. - (* Section CODE. *) - (* (** converting trace to code **) *) - - (* (* converting functions *) *) - (* 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) (Tcons (eventval_to_type v) Tnil)) ((ptr_of_id_ofs id ofs) :: (eventval_to_expr v) :: nil). *) - - (* 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). *) - - (* (* 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_return (cp cp': compartment) (v: eventval) := *) - (* Sreturn (Some (eventval_to_expr v)). *) - - (* Definition code_of_event (e: event): statement := *) - (* match e with *) - (* | 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_syscall name vs v => code_of_syscall name vs v *) - (* | Event_return cp cp' v => code_of_return cp cp' v *) - (* end. *) - - (* (* A while(1)-loop with a big switch inside it *) *) - (* Definition code_of_trace cp (t: trace): statement := *) - (* Swhile (Econst_int Int.one (Tint I32 Signed noattr)) (switch cp (map code_of_event t) (Sreturn None)). *) - - (* End CODE. *) - - Section CODEPROP. Let cgenv := Genv.t fundef type. @@ -895,7 +851,6 @@ Section Backtranslation. econstructor 1. Qed. - (* TODO *) Lemma code_of_event_step_call_internal p f k e le m ge @@ -950,486 +905,120 @@ Section Backtranslation. End CODEPROP. - (* Section CODEPROP. *) - (* (* Properties *) *) - (* Lemma ptr_of_id_ofs_eval *) - (* id ofs e (ge: genv) b cp le m *) - (* (GE1: wf_env e id) *) - (* (GE2: Genv.find_symbol ge id = Some b) *) - (* : *) - (* eval_expr ge e cp le m (ptr_of_id_ofs id ofs) (Vptr b ofs). *) - (* Proof. *) - (* 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 eventval_to_expr_match *) - (* (ge: genv) env cp le m *) - (* ev exp v ty *) - (* (WFENV: wf_eventval_env env ev) *) - (* (WFGE: wf_eventval_pub ge ev) *) - (* (CONV: eventval_to_expr ev = exp) *) - (* (EVAL: eval_expr ge env cp le m exp v) *) - (* (TYPE: typ_of_type (eventval_to_type ev) = ty) *) - (* : *) - (* eventval_match ge ev ty v. *) - (* Proof. *) - (* subst. destruct ev; simpl in *. *) - (* - inversion EVAL; subst; simpl in *; try constructor. inversion H. *) - (* - inversion EVAL; subst; simpl in *; try constructor. inversion H. *) - (* - inversion EVAL; subst; simpl in *; try constructor. inversion H. *) - (* - inversion EVAL; subst; simpl in *; try constructor. inversion H. *) - (* - unfold ptr_of_id_ofs in EVAL. destruct Archi.ptr64 eqn:ARCH. *) - (* + inversion EVAL; subst; simpl in *; try constructor. *) - (* 2:{ inversion H. } *) - (* inversion H5; subst; simpl in *. *) - (* 2:{ inversion H. } *) - (* clear H5. inversion H4; subst; simpl in *. *) - (* 2:{ inversion H. } *) - (* clear H4. inversion H2; subst; simpl. *) - (* { rewrite WFENV in H4. inversion H4. } *) - (* { inversion H6. *) - (* rewrite Ptrofs.mul_commut, Ptrofs.mul_one. *) - (* rewrite Ptrofs.add_zero_l. *) - (* replace (Ptrofs.of_int64 (Ptrofs.to_int64 i0)) with i0. *) - (* constructor; auto. *) - (* symmetry. apply Ptrofs.of_int64_to_int64. auto. *) - (* } *) - (* + inversion EVAL; subst; simpl in *; try constructor. *) - (* 2:{ inversion H. } *) - (* inversion H5; subst; simpl in *. *) - (* 2:{ inversion H. } *) - (* clear H5. inversion H4; subst; simpl in *. *) - (* 2:{ inversion H. } *) - (* clear H4. inversion H2; subst; simpl. *) - (* { rewrite WFENV in H4. inversion H4. } *) - (* { inversion H6. *) - (* rewrite Ptrofs.mul_commut, Ptrofs.mul_one. *) - (* rewrite Ptrofs.add_zero_l. *) - (* replace (Ptrofs.of_ints (Ptrofs.to_int i0)) with i0. *) - (* constructor; auto. *) - (* symmetry. apply Ptrofs.agree32_of_ints_eq; auto. *) - (* apply Ptrofs.agree32_to_int; auto. *) - (* } *) - (* Qed. *) - - (* Lemma eventval_to_expr_val_eval *) - (* (ge: genv) en cp temp m ev *) - (* (WFENV: wf_eventval_env en ev) *) - (* (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. *) - (* destruct WFGE as [b WFGE]. *) - (* rewrite WFGE. unfold ptr_of_id_ofs. destruct Archi.ptr64 eqn:ARCH. *) - (* - econstructor; try econstructor. eapply eval_Evar_global; eauto. *) - (* simpl. simpl_expr. rewrite Ptrofs.mul_commut, Ptrofs.mul_one. rewrite Ptrofs.add_zero_l. *) - (* rewrite Ptrofs.of_int64_to_int64; auto. *) - (* - econstructor; try econstructor. eapply eval_Evar_global; eauto. *) - (* 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 eventval_to_expr_val_match *) - (* (ge: genv) env *) - (* ev exp v ty *) - (* (WFENV: wf_eventval_env env ev) *) - (* (WFEV: wf_eventval_pub ge ev) *) - (* (CONV0: eventval_to_expr ev = exp) *) - (* (CONV1: eventval_to_val ge ev = v) *) - (* (TYPE: typ_of_type (eventval_to_type ev) = ty) *) - (* : *) - (* eventval_match ge ev ty v. *) - (* Proof. *) - (* subst. eapply eventval_to_expr_match; eauto. eapply eventval_to_expr_val_eval; eauto. apply wf_eventval_pub_ge; auto. *) - (* Unshelve. exact default_compartment. exact (PTree.empty val). exact Mem.empty. *) - (* Qed. *) - - (* Lemma sem_cast_eventval *) - (* (ge: genv) 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_eval *) - (* (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 list_eventval_to_expr_val_match *) - (* (ge: genv) env *) - (* evs exps vs tys *) - (* (WFENV: Forall (wf_eventval_env env) evs) *) - (* (WFPUB: Forall (wf_eventval_pub ge) evs) *) - (* (CONV0: list_eventval_to_list_expr evs = exps) *) - (* (CONV1: list_eventval_to_list_val ge evs = vs) *) - (* (TYPE: list_eventval_to_typelist evs = tys) *) - (* : *) - (* eventval_list_match ge evs (typlist_of_typelist tys) vs. *) - (* Proof. *) - (* move evs at top. revert ge env exps vs tys WFENV WFPUB CONV0 CONV1 TYPE. *) - (* induction evs; intros; simpl in *; subst. constructor. *) - (* inversion WFENV; clear WFENV; subst. inversion WFPUB; clear WFPUB; subst. *) - (* econstructor; eauto. eapply eventval_to_expr_val_match; eauto. *) - (* Qed. *) - - - (* Lemma code_of_event_step_vload *) - (* ev *) - (* ch id ofs v *) - (* p f k e le m *) - (* (EV: ev = Event_vload ch id ofs v) *) - (* (* bt should ensure them *) *) - (* (WFENV: wf_env e id) *) - (* b *) - (* (VOL: Senv.block_is_volatile (globalenv p) b = true) *) - (* (GE: Genv.find_symbol (globalenv p) id = Some b) *) - (* (* asm should ensure them *) *) - (* rv *) - (* (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) rv) *) - (* : *) - (* Star (Clight.semantics1 p) *) - (* (State f (code_of_event ev) k e le m) *) - (* (ev :: nil) *) - (* (State f Sskip k e le m). *) - (* Proof. *) - (* subst; simpl in *. unfold code_of_vload. *) - (* destruct Archi.ptr64 eqn:ARCH. *) - (* - econstructor 2. *) - (* 3:{ rewrite E0_right. reflexivity. } *) - (* { eapply step_builtin. *) - (* { econstructor; eauto. 3: econstructor. *) - (* - eapply ptr_of_id_ofs_eval; eauto. *) - (* - unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. *) - (* } *) - (* repeat econstructor; eauto. *) - (* } *) - (* econstructor 1. *) - (* - econstructor 2. *) - (* 3:{ rewrite E0_right. reflexivity. } *) - (* { eapply step_builtin. *) - (* { econstructor; eauto. 3: econstructor. *) - (* - eapply ptr_of_id_ofs_eval; eauto. *) - (* - unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. *) - (* } *) - (* repeat econstructor; eauto. *) - (* } *) - (* econstructor 1. *) - (* Qed. *) - - (* Lemma code_of_event_step_vstore *) - (* ev *) - (* ch id ofs v *) - (* p f k e le m *) - (* (EV: ev = Event_vstore ch id ofs v) *) - (* (* bt should ensure them *) *) - (* (WFENV: wf_env e id) *) - (* b *) - (* (VOL: Senv.block_is_volatile (globalenv p) b = true) *) - (* (GE: Genv.find_symbol (globalenv p) id = Some b) *) - (* (* asm should ensure them *) *) - (* (WFSV1: wf_eventval_env e v) *) - (* (WFSV2: wf_eventval_ge (globalenv p) v) *) - (* (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) (Val.load_result ch (eventval_to_val (globalenv p) v))) *) - (* : *) - (* Star (Clight.semantics1 p) *) - (* (State f (code_of_event ev) k e le m) *) - (* (ev :: nil) *) - (* (State f Sskip k e le m). *) - (* Proof. *) - (* subst; simpl in *. unfold code_of_vstore. *) - (* destruct Archi.ptr64 eqn:ARCH. *) - (* - econstructor 2. *) - (* 3:{ rewrite E0_right. reflexivity. } *) - (* { eapply step_builtin. *) - (* { econstructor; eauto. *) - (* { eapply ptr_of_id_ofs_eval; eauto. } *) - (* { unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. } *) - (* econstructor; eauto. 3: econstructor. *) - (* { eapply eventval_to_expr_val_eval; auto. } *) - (* { apply sem_cast_eventval; auto. } *) - (* } *) - (* simpl. *) - (* repeat econstructor; eauto. *) - (* } *) - (* econstructor 1. *) - (* - econstructor 2. *) - (* 3:{ rewrite E0_right. reflexivity. } *) - (* { eapply step_builtin. *) - (* { econstructor; eauto. *) - (* { eapply ptr_of_id_ofs_eval; eauto. } *) - (* { unfold ptr_of_id_ofs; simpl. rewrite ARCH. simpl. simpl_expr. } *) - (* econstructor; eauto. 3: econstructor. *) - (* { eapply eventval_to_expr_val_eval; auto. } *) - (* { apply sem_cast_eventval; auto. } *) - (* } *) - (* simpl. *) - (* repeat econstructor; eauto. *) - (* } *) - (* econstructor 1. *) - (* Qed. *) - - (* Lemma code_of_event_step_annot *) - (* ev *) - (* str vs *) - (* p f k e le m *) - (* (EV: ev = Event_annot str vs) *) - (* (* bt should ensure them *) *) - (* (WFENV: Forall (wf_eventval_env e) vs) *) - (* (WFPUB: Forall (wf_eventval_pub (globalenv p)) vs) *) - (* (* asm should ensure them *) *) - (* : *) - (* Star (Clight.semantics1 p) *) - (* (State f (code_of_event ev) k e le m) *) - (* (ev :: nil) *) - (* (State f Sskip k e le m). *) - (* Proof. *) - (* subst; simpl in *. unfold code_of_annot. *) - (* econstructor 2. *) - (* 3:{ rewrite E0_right. reflexivity. } *) - (* { eapply step_builtin. *) - (* { eapply list_eventval_to_expr_val_eval; auto. *) - (* eapply Forall_impl. 2: eauto. intros. apply wf_eventval_pub_ge; auto. } *) - (* repeat econstructor; eauto. eapply list_eventval_to_expr_val_match; eauto. *) - (* } *) - (* econstructor 1. *) - (* Qed. *) - - (* (* TODO: return type? *) *) - (* Lemma code_of_event_step_call_start *) - (* ev *) - (* cp cp' id vs *) - (* p f k e le m *) - (* ge *) - (* (GE: ge = globalenv p) *) - (* (EV: ev = Event_call cp cp' id vs) *) - (* (* bt should ensure them *) *) - (* (GLOB: e ! id = None) *) - (* b *) - (* (FINDB: Genv.find_symbol ge id = Some b) *) - (* fd *) - (* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) *) - (* (TYPEF: type_of_fundef fd = Tfunction (list_eventval_to_typelist vs) Tvoid cc_default) *) - (* (WFARGS1: Forall (wf_eventval_env e) vs) *) - (* (WFARGS2: Forall (wf_eventval_pub ge) vs) *) - (* (* asm should ensure them *) *) - (* (CP1: cp = comp_of f) *) - (* (CP2: cp' = comp_of fd) *) - (* (NPTR: Forall not_ptr (list_eventval_to_list_val ge vs)) *) - (* (CROSS: Genv.type_of_call ge (comp_of f) (comp_of fd) = Genv.CrossCompartmentCall) *) - (* (ALLOW: Genv.allowed_cross_call ge (comp_of f) (Vptr b Ptrofs.zero)) *) - (* : *) - (* Star (Clight.semantics1 p) *) - (* (State f (code_of_event ev) k e le m) *) - (* (ev :: nil) *) - (* (Callstate fd (list_eventval_to_list_val ge vs) (Kcall None f e le k) m). *) - (* Proof. *) - (* subst; simpl. unfold code_of_call. *) - (* econstructor 2. *) - (* 3:{ rewrite E0_right. reflexivity. } *) - (* { eapply step_call; simpl; eauto. *) - (* { eapply eval_Elvalue. *) - (* - eapply eval_Evar_global; eauto. *) - (* - eapply deref_loc_reference. auto. *) - (* } *) - (* { eapply list_eventval_to_expr_val_eval; auto. *) - (* eapply Forall_impl. 2: eauto. intros. apply wf_eventval_pub_ge; auto. } *) - (* red; auto. *) - (* unfold Genv.find_comp. setoid_rewrite FINDF. *) - (* eapply call_trace_cross; eauto. apply Genv.find_invert_symbol; auto. *) - (* eapply (list_eventval_to_expr_val_match (globalenv p)); eauto. *) - (* } *) - (* econstructor 1. *) - (* Qed. *) - - (* Lemma code_of_event_step_call_internal *) - (* p f k e le m *) - (* ge *) - (* (GE: ge = globalenv p) *) - (* (* bt should ensure them *) *) - (* fd args f1 *) - (* (INTERNAL: fd = Internal f1) *) - (* (* asm should ensure them *) *) - (* (* handle during proving *) *) - (* e1 le1 m1 *) - (* (ENTRY: function_entry1 ge f1 args m e1 le1 m1) *) - (* : *) - (* Star (Clight.semantics1 p) *) - (* (Callstate fd args (Kcall None f e le k) m) *) - (* nil *) - (* (State f1 (fn_body f1) (Kcall None f e le k) e1 le1 m1). *) - (* Proof. *) - (* subst; simpl. *) - (* econstructor 2. *) - (* 3:{ rewrite E0_right. reflexivity. } *) - (* { eapply step_internal_function; eauto. } *) - (* econstructor 1. *) - (* Qed. *) - - (* Lemma code_of_event_step_call_external *) - (* p m *) - (* ge *) - (* (GE: ge = globalenv p) *) - (* (* bt should ensure them *) *) - (* fd k args ef targs tres cconv *) - (* (EXTERNAL: fd = External ef targs tres cconv) *) - (* (* asm should ensure them *) *) - (* sev *) - (* vres m1 *) - (* (SEM: external_call ef ge (call_comp k) args m (sev :: nil) vres m1) *) - (* (* handle during proving *) *) - (* sname sargs svr *) - (* (SYSEV: sev = Event_syscall sname sargs svr) *) - (* : *) - (* Star (Clight.semantics1 p) *) - (* (Callstate fd args k m) *) - (* (sev :: nil) *) - (* (Returnstate vres k m1 (rettype_of_type tres) (comp_of ef)). *) - (* Proof. *) - (* subst; simpl. *) - (* econstructor 2. *) - (* 3:{ rewrite E0_right. reflexivity. } *) - (* { eapply step_external_function; eauto. } *) - (* econstructor 1. *) - (* Qed. *) - - (* Lemma code_of_event_step_return *) - (* ev *) - (* cp cp' rv *) - (* p f k e le m *) - (* ge *) - (* (GE: ge = globalenv p) *) - (* (EV: ev = Event_return cp' cp rv) *) - (* (* bt should ensure them *) *) - (* (WFRV1: wf_eventval_env e rv) *) - (* (WFRV2: wf_eventval_pub ge rv) *) - (* (RTTYP: fn_return f = eventval_to_type rv) *) - (* (* asm should ensure them *) *) - (* optid f' e' le' k' *) - (* (CONT: call_cont k = Kcall optid f' e' le' k') *) - (* (CP1: cp = comp_of f) *) - (* (CP2: cp' = comp_of f') *) - (* (NPTR: not_ptr (eventval_to_val ge rv)) *) - (* (CROSS: Genv.type_of_call ge (comp_of f') (comp_of f) = Genv.CrossCompartmentCall) *) - (* (* handle during proving *) *) - (* m' *) - (* (FREE: Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m') *) - (* : *) - (* Star (Clight.semantics1 p) *) - (* (State f (code_of_event ev) k e le m) *) - (* (ev :: nil) *) - (* (State f' Sskip k' e' (set_opttemp optid (eventval_to_val ge rv) le') m'). *) - (* Proof. *) - (* subst; simpl. unfold code_of_return. *) - (* econstructor 2. *) - (* 3:{ rewrite E0_left. reflexivity. } *) - (* { eapply step_return_1; simpl; eauto. *) - (* { eapply eventval_to_expr_val_eval; auto. apply wf_eventval_pub_ge; auto. } *) - (* { rewrite RTTYP. eapply sem_cast_eventval; auto. eapply wf_eventval_pub_ge; eauto. } *) - (* } *) - (* econstructor 2. *) - (* 3:{ rewrite E0_right. reflexivity. } *) - (* { rewrite CONT. eapply step_returnstate; auto. *) - (* econstructor 2; auto. rewrite RTTYP. eapply eventval_to_expr_val_match; eauto. *) - (* clear. destruct rv; simpl; auto. *) - (* } *) - (* econstructor 1. *) - (* Qed. *) - - (* End CODEPROP. *) - - Section WELLFORMED. - (* wf_sem *) + (* wf_sem: from asm, wf_st: proof invariant for Clight states *) Definition wf_sem_vload {F V} (ge: Genv.t F V) (ch: memory_chunk) (id: ident) (ofs: ptrofs) (v: eventval) := (exists b, (Genv.find_symbol ge id = Some b) /\ (Senv.block_is_volatile ge b = true)) /\ (exists rv, (eventval_match ge v (type_of_chunk ch) rv)). + Definition wf_st_vload (ch: memory_chunk) (id: ident) (ofs: ptrofs) (v: eventval) e := + (wf_env e id). + Definition wf_sem_vstore {F V} (ge: Genv.t F V) (ch: memory_chunk) (id: ident) (ofs: ptrofs) v := (exists b, (Genv.find_symbol ge id = Some b) /\ (Senv.block_is_volatile ge b = true)) /\ - (wf_eventval_ge ge v) /\ - (eventval_match ge v (type_of_chunk ch) (Val.load_result ch (eventval_to_val ge v))). + (exists vv, eventval_match ge v (type_of_chunk ch) (Val.load_result ch vv)). + + Definition wf_st_vstore (ch: memory_chunk) (id: ident) (ofs: ptrofs) v e := + (wf_env e id) /\ (wf_eventval_env e v). Definition wf_sem_annot {F V} (ge: Genv.t F V) (str: string) (vs: list eventval) := - (Forall (wf_eventval_pub ge) vs). + exists targs vargs, eventval_list_match ge vs targs vargs. - Definition wf_sem_call_internal {F V} {CF: has_comp F} (FD: (list eventval) -> F -> Prop) (ge: Genv.t F V) (cp cp': compartment) (id: ident) (vs: list eventval) := - (Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) /\ - ((Forall (wf_eventval_pub ge) vs) /\ (Forall not_ptr (list_eventval_to_list_val ge vs))) /\ - exists b, - (Genv.find_symbol ge id = Some b) /\ (Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) /\ - (exists fd, (Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) /\ (cp' = comp_of fd) /\ (FD vs fd)). - (* (TYPEF: type_of_fundef fd = Tfunction (list_eventval_to_typelist vs) Tvoid cc_default) *) - (* (INTERNAL: fd = Internal f1) *) + Definition wf_st_annot (str: string) (vs: list eventval) e := + (Forall (wf_eventval_env e) vs). + + Definition wf_sem_call_start_cl (p: Clight.program) (cp cp': compartment) (id: ident) (vs: list eventval) := + let ge := globalenv p in + exists data, + ((from_cl_funs_data p) ! id = Some data) /\ + exists b, + (Genv.find_symbol ge id = Some b) /\ + exists fd, + (Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) /\ + (type_of_fundef fd = Tfunction data.(dargs) data.(dret) data.(dcc)) /\ + (cp' = comp_of fd) /\ + (Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) /\ + (Forall not_ptr (list_eventval_to_list_val ge vs)) /\ + (Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) /\ + exists some_sig_args some_vals, + (eventval_list_match ge vs some_sig_args some_vals) /\ + (data.(dargs) = (list_typ_to_typelist some_sig_args)). + + Definition wf_st_call_start (cp cp': compartment) (id: ident) (vs: list eventval) e (f: Clight.function) := + (e ! id = None) /\ (Forall (wf_eventval_env e) vs) /\ (cp = comp_of f). Definition wf_sem_return {F V} (ge: Genv.t F V) (cp cp': compartment) (rv: eventval) := - (wf_eventval_pub ge rv) /\ + (Genv.type_of_call ge cp' cp = Genv.CrossCompartmentCall) /\ (not_ptr (eventval_to_val ge rv)) /\ - (Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall). + exists some_sig_ret some_val, + (eventval_match ge rv some_sig_ret some_val). - (* wf_bt *) - - - (* wf_inv *) - Definition wf_inv_vload (ch: memory_chunk) (id: ident) (ofs: ptrofs) (v: eventval) e := - (wf_env e id). - - Definition wf_inv_vstore (ch: memory_chunk) (id: ident) (ofs: ptrofs) v e := - (wf_env e id) /\ (wf_eventval_env e v). - - Definition wf_inv_annot (str: string) (vs: list eventval) e := - (Forall (wf_eventval_env e) vs). - - Definition wf_inv_call_internal (cp cp': compartment) (id: ident) (vs: list eventval) e := - (e ! id = None) /\ (Forall (wf_eventval_env e) vs). - (* (CP1: cp = comp_of f) *) - - Definition wf_inv_return (cp cp': compartment) (rv: eventval) e (k: cont) := + Definition wf_st_return (ge: genv) (cp cp': compartment) (rv: eventval) e (f: Clight.function) (k: cont) (m: mem) := (wf_eventval_env e rv) /\ + (cp = comp_of f) /\ + (forall some_sig_ret some_val, (eventval_match ge rv some_sig_ret some_val) -> (fn_return f = typ_to_type some_sig_ret)) /\ exists optid f' e' le' k', (call_cont k = Kcall optid f' e' le' k') /\ - (cp = comp_of f'). - (* (fn_return f = eventval_to_type rv) *) - (* (CP1: cp' = comp_of f) *) + (cp' = comp_of f') /\ + exists m', + (Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m'). + + (* TODO *) - | step_return_1 : forall (f : function) (a : expr) (k : cont) (e : env) (le : temp_env) (m : mem) (v v' : val) (m' : mem), - eval_expr ge e (comp_of f) le m a v -> - Cop.sem_cast v (typeof a) (fn_return f) m = Some v' -> - Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m' -> - step ge function_entry (State f (Sreturn (Some a)) k e le m) E0 (Returnstate v' (call_cont k) m' (rettype_of_type (fn_return f)) (comp_of f)) - | step_returnstate : forall (v : val) (optid : option ident) (f : function) (e : env) (le : temp_env) (ty : rettype) (cp : compartment) (k : cont) (m : mem) (t : trace), - (Genv.type_of_call ge (comp_of f) cp = Genv.CrossCompartmentCall -> not_ptr v) -> - return_trace ge (comp_of f) cp v ty t -> step ge function_entry (Returnstate v (Kcall optid f e le k) m ty cp) t (State f Sskip k e (set_opttemp optid v le) m). -Inductive return_trace (F V : Type) (ge : Genv.t F V) : compartment -> compartment -> val -> rettype -> trace -> Prop := - return_trace_intra : forall (cp cp' : compartment) (v : val) (ty : rettype), Genv.type_of_call ge cp cp' <> Genv.CrossCompartmentCall -> return_trace ge cp cp' v ty E0 - | return_trace_cross : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype), - Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> eventval_match ge res (proj_rettype ty) v -> return_trace ge cp cp' v ty (Event_return cp cp' res :: nil). -Inductive eventval_match (ge : Senv.t) : eventval -> typ -> val -> Prop := - ev_match_int : forall i : int, eventval_match ge (EVint i) AST.Tint (Vint i) - | ev_match_long : forall i : int64, eventval_match ge (EVlong i) AST.Tlong (Vlong i) - | ev_match_float : forall f : Floats.float, eventval_match ge (EVfloat f) AST.Tfloat (Vfloat f) - | ev_match_single : forall f : Floats.float32, eventval_match ge (EVsingle f) Tsingle (Vsingle f) - | ev_match_ptr : forall (id : ident) (b : block) (ofs : ptrofs), Senv.public_symbol ge id = true -> Senv.find_symbol ge id = Some b -> eventval_match ge (EVptr_global id ofs) Tptr (Vptr b ofs). + (* we need a more precise invariant for the proof, e.g. counters, mem_inj *) + Lemma code_of_event_step_call_internal + p f k e le m + ge + (GE: ge = globalenv p) + (* bt should ensure them *) + fd args f1 + (INTERNAL: fd = Internal f1) + (* asm should ensure them *) + (* handle during proving *) + e1 le1 m1 + (ENTRY: function_entry1 ge f1 args m e1 le1 m1) + : + Star (Clight.semantics1 p) + (Callstate fd args (Kcall None f e le k) m) + nil + (State f1 (fn_body f1) (Kcall None f e le k) e1 le1 m1). + Proof. + subst; simpl. + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_internal_function; eauto. } + econstructor 1. + Qed. + + Lemma code_of_event_step_call_external + p m + ge + (GE: ge = globalenv p) + (* bt should ensure them *) + fd k args ef targs tres cconv + (EXTERNAL: fd = External ef targs tres cconv) + (* asm should ensure them *) + sev + vres m1 + (SEM: external_call ef ge (call_comp k) args m (sev :: nil) vres m1) + (* handle during proving *) + sname sargs svr + (SYSEV: sev = Event_syscall sname sargs svr) + : + Star (Clight.semantics1 p) + (Callstate fd args k m) + (sev :: nil) + (Returnstate vres k m1 (rettype_of_type tres) (comp_of ef)). + Proof. + subst; simpl. + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_external_function; eauto. } + econstructor 1. + Qed. + (** Events.v **) (* (** External calls must commute with memory injections, *) From d07f49f07a4e676650de298a6a0f591f1209fca2 Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 21 Apr 2023 15:55:35 +0200 Subject: [PATCH 023/174] WIP: invariant for cl --- security/Backtranslation.v | 104 ++++++++++++++----------------------- 1 file changed, 39 insertions(+), 65 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 9f716033c9..8cfeef5801 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -928,26 +928,31 @@ Section Backtranslation. Definition wf_st_annot (str: string) (vs: list eventval) e := (Forall (wf_eventval_env e) vs). - Definition wf_sem_call_start_cl (p: Clight.program) (cp cp': compartment) (id: ident) (vs: list eventval) := - let ge := globalenv p in - exists data, - ((from_cl_funs_data p) ! id = Some data) /\ - exists b, - (Genv.find_symbol ge id = Some b) /\ - exists fd, - (Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) /\ - (type_of_fundef fd = Tfunction data.(dargs) data.(dret) data.(dcc)) /\ - (cp' = comp_of fd) /\ - (Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) /\ - (Forall not_ptr (list_eventval_to_list_val ge vs)) /\ - (Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) /\ - exists some_sig_args some_vals, - (eventval_list_match ge vs some_sig_args some_vals) /\ - (data.(dargs) = (list_typ_to_typelist some_sig_args)). + Definition wf_sem_call_start_cl (ge: genv) (cp cp': compartment) (id: ident) (vs: list eventval) := + exists b, + (Genv.find_symbol ge id = Some b) /\ + exists fd, + (Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) /\ + let data := from_clfd_fun_data fd in + (type_of_fundef fd = Tfunction data.(dargs) data.(dret) data.(dcc)) /\ + (cp' = comp_of fd) /\ + (Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) /\ + (Forall not_ptr (list_eventval_to_list_val ge vs)) /\ + (Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) /\ + exists some_sig_args some_vals, + (eventval_list_match ge vs some_sig_args some_vals) /\ + (data.(dargs) = (list_typ_to_typelist some_sig_args)). Definition wf_st_call_start (cp cp': compartment) (id: ident) (vs: list eventval) e (f: Clight.function) := (e ! id = None) /\ (Forall (wf_eventval_env e) vs) /\ (cp = comp_of f). + Definition wf_st_call_internal (ge: genv) (vs: list eventval) (f1: Clight.function) m := + exists e1 le1 m1, function_entry1 ge f1 (list_eventval_to_list_val ge vs) m e1 le1 m1. + + Definition wf_st_call_external (ge: genv) (vs: list eventval) k m sname sargs svr ef := + let sev := Event_syscall sname sargs svr in + exists vres m1, (external_call ef ge (call_comp k) (list_eventval_to_list_val ge vs) m (sev :: nil) vres m1). + Definition wf_sem_return {F V} (ge: Genv.t F V) (cp cp': compartment) (rv: eventval) := (Genv.type_of_call ge cp' cp = Genv.CrossCompartmentCall) /\ (not_ptr (eventval_to_val ge rv)) /\ @@ -965,59 +970,28 @@ Section Backtranslation. (Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m'). + Inductive wf_inv_cl (ge: genv) : Clight.function -> cont -> env -> mem -> trace -> Prop := + | wf_inv_vload + f k e m t + ch id ofs v + (SEM: wf_sem_vload ge ch id ofs v) + (ST: wf_st_vload ch id ofs v e) + (IND: wf_inv_cl ge f k e m t) + : + wf_inv_cl ge f k e m (Event_vload ch id ofs v :: t) + | wf_inv_vstore + f k e m t + ch id ofs v + (SEM: wf_sem_vstore ge ch id ofs v) + (ST: wf_st_vstore ch id ofs v e) + (IND: wf_inv_cl ge f k e m t) + : + wf_inv_cl ge f k e m (Event_vstore ch id ofs v :: t) + . (* TODO *) (* we need a more precise invariant for the proof, e.g. counters, mem_inj *) - Lemma code_of_event_step_call_internal - p f k e le m - ge - (GE: ge = globalenv p) - (* bt should ensure them *) - fd args f1 - (INTERNAL: fd = Internal f1) - (* asm should ensure them *) - (* handle during proving *) - e1 le1 m1 - (ENTRY: function_entry1 ge f1 args m e1 le1 m1) - : - Star (Clight.semantics1 p) - (Callstate fd args (Kcall None f e le k) m) - nil - (State f1 (fn_body f1) (Kcall None f e le k) e1 le1 m1). - Proof. - subst; simpl. - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_internal_function; eauto. } - econstructor 1. - Qed. - Lemma code_of_event_step_call_external - p m - ge - (GE: ge = globalenv p) - (* bt should ensure them *) - fd k args ef targs tres cconv - (EXTERNAL: fd = External ef targs tres cconv) - (* asm should ensure them *) - sev - vres m1 - (SEM: external_call ef ge (call_comp k) args m (sev :: nil) vres m1) - (* handle during proving *) - sname sargs svr - (SYSEV: sev = Event_syscall sname sargs svr) - : - Star (Clight.semantics1 p) - (Callstate fd args k m) - (sev :: nil) - (Returnstate vres k m1 (rettype_of_type tres) (comp_of ef)). - Proof. - subst; simpl. - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_external_function; eauto. } - econstructor 1. - Qed. (** Events.v **) From 4040d4c0ad32213a282b1064a8a9e2f3caf7e3f7 Mon Sep 17 00:00:00 2001 From: ldj Date: Sun, 23 Apr 2023 11:23:54 +0200 Subject: [PATCH 024/174] WIP --- security/Backtranslation.v | 82 ++++++++++++++++++++++++++++---------- 1 file changed, 60 insertions(+), 22 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 8cfeef5801..2e5520fd9f 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -907,6 +907,8 @@ Section Backtranslation. Section WELLFORMED. + Definition empty_le := PTree.empty val. + (* wf_sem: from asm, wf_st: proof invariant for Clight states *) Definition wf_sem_vload {F V} (ge: Genv.t F V) (ch: memory_chunk) (id: ident) (ofs: ptrofs) (v: eventval) := (exists b, (Genv.find_symbol ge id = Some b) /\ (Senv.block_is_volatile ge b = true)) /\ @@ -928,30 +930,29 @@ Section Backtranslation. Definition wf_st_annot (str: string) (vs: list eventval) e := (Forall (wf_eventval_env e) vs). - Definition wf_sem_call_start_cl (ge: genv) (cp cp': compartment) (id: ident) (vs: list eventval) := + Definition wf_sem_call_start_cl (ge: genv) (cp cp': compartment) (id: ident) (vs: list eventval) (fd: Clight.fundef) := exists b, (Genv.find_symbol ge id = Some b) /\ - exists fd, - (Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) /\ - let data := from_clfd_fun_data fd in - (type_of_fundef fd = Tfunction data.(dargs) data.(dret) data.(dcc)) /\ - (cp' = comp_of fd) /\ - (Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) /\ - (Forall not_ptr (list_eventval_to_list_val ge vs)) /\ - (Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) /\ - exists some_sig_args some_vals, - (eventval_list_match ge vs some_sig_args some_vals) /\ - (data.(dargs) = (list_typ_to_typelist some_sig_args)). + (Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) /\ + let data := from_clfd_fun_data fd in + (type_of_fundef fd = Tfunction data.(dargs) data.(dret) data.(dcc)) /\ + (cp' = comp_of fd) /\ + (Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) /\ + (Forall not_ptr (list_eventval_to_list_val ge vs)) /\ + (Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) /\ + exists some_sig_args some_vals, + (eventval_list_match ge vs some_sig_args some_vals) /\ + (data.(dargs) = (list_typ_to_typelist some_sig_args)). Definition wf_st_call_start (cp cp': compartment) (id: ident) (vs: list eventval) e (f: Clight.function) := (e ! id = None) /\ (Forall (wf_eventval_env e) vs) /\ (cp = comp_of f). - Definition wf_st_call_internal (ge: genv) (vs: list eventval) (f1: Clight.function) m := - exists e1 le1 m1, function_entry1 ge f1 (list_eventval_to_list_val ge vs) m e1 le1 m1. + Definition wf_st_call_internal (ge: genv) (vs: list eventval) (f1: Clight.function) m e1 m1 := + function_entry1 ge f1 (list_eventval_to_list_val ge vs) m e1 empty_le m1. - Definition wf_st_call_external (ge: genv) (vs: list eventval) k m sname sargs svr ef := + Definition wf_st_call_external (ge: genv) (vs: list eventval) k m sname sargs svr ef m1 := let sev := Event_syscall sname sargs svr in - exists vres m1, (external_call ef ge (call_comp k) (list_eventval_to_list_val ge vs) m (sev :: nil) vres m1). + exists vres, (external_call ef ge (call_comp k) (list_eventval_to_list_val ge vs) m (sev :: nil) vres m1). Definition wf_sem_return {F V} (ge: Genv.t F V) (cp cp': compartment) (rv: eventval) := (Genv.type_of_call ge cp' cp = Genv.CrossCompartmentCall) /\ @@ -959,15 +960,13 @@ Section Backtranslation. exists some_sig_ret some_val, (eventval_match ge rv some_sig_ret some_val). - Definition wf_st_return (ge: genv) (cp cp': compartment) (rv: eventval) e (f: Clight.function) (k: cont) (m: mem) := + Definition wf_st_return (ge: genv) (cp cp': compartment) (rv: eventval) e (f: Clight.function) (k: cont) (m: mem) f' k' e' m' := (wf_eventval_env e rv) /\ (cp = comp_of f) /\ (forall some_sig_ret some_val, (eventval_match ge rv some_sig_ret some_val) -> (fn_return f = typ_to_type some_sig_ret)) /\ - exists optid f' e' le' k', - (call_cont k = Kcall optid f' e' le' k') /\ - (cp' = comp_of f') /\ - exists m', - (Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m'). + (call_cont k = Kcall None f' e' empty_le k') /\ + (cp' = comp_of f') /\ + (Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m'). Inductive wf_inv_cl (ge: genv) : Clight.function -> cont -> env -> mem -> trace -> Prop := @@ -987,6 +986,45 @@ Section Backtranslation. (IND: wf_inv_cl ge f k e m t) : wf_inv_cl ge f k e m (Event_vstore ch id ofs v :: t) + | wf_inv_annot + f k e m t + str vs + (SEM: wf_sem_annot ge str vs) + (ST: wf_st_annot str vs e) + (IND: wf_inv_cl ge f k e m t) + : + wf_inv_cl ge f k e m (Event_annot str vs :: t) + + | wf_inv_call_internal + f k e m t + cp cp' id vs + fd + (SEM: wf_sem_call_start_cl ge cp cp' id vs fd) + (ST: wf_st_call_start cp cp' id vs e f) + f1 e1 m1 + (ISINT: fd = Internal f1) + (INT: wf_st_call_internal ge vs f1 m e1 m1) + (IND: wf_inv_cl ge f1 (Kcall None f e empty_le k) e1 m1 t) + : + wf_inv_cl ge f k e m (Event_call cp cp' id vs :: t) + | wf_inv_return + f k e m t + cp cp' rv + (SEM: wf_sem_return ge cp cp' rv) + f' k' e' m' + (ST: wf_st_return ge cp cp' rv e f k m f' k' e' m') + (IND: wf_inv_cl ge f' k' e' m' t) + : + wf_inv_cl ge f k e m (Event_return cp cp' rv :: t). + + + Definition wf_st_call_external (ge: genv) (vs: list eventval) k m sname sargs svr ef m1 := + let sev := Event_syscall sname sargs svr in + exists vres, (external_call ef ge (call_comp k) (list_eventval_to_list_val ge vs) m (sev :: nil) vres m1). + + + + . (* TODO *) From 57dca0884086557df7bbb5ec1895591e7af05fff Mon Sep 17 00:00:00 2001 From: ldj Date: Sun, 23 Apr 2023 17:22:40 +0200 Subject: [PATCH 025/174] WIP --- security/Backtranslation.v | 39 ++++++++++++++++++++++++++++---------- 1 file changed, 29 insertions(+), 10 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 2e5520fd9f..018121a412 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -462,10 +462,22 @@ Section Backtranslation. end in Scall None (Evar id (Tfunction targs tret cc)) (list_eventval_to_list_expr vs). - (* Scall None (Evar id (Tfunction (list_eventval_to_typelist vs) Tvoid cc_default)) (list_eventval_to_list_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. + (* Two cases for invoking an Event_syscall: + 1. cross-compartment. follows a call event, so just a skip is enough. + 2. intra-compartment. need to execute a 'Scall'. We define this case. + *) + (** need function: external call name -> id **) + (** need axiom: 'Event_syscall name _ _' can be uniquely converted into an ident. **) + Variable syscall_ident: string -> ident. + Definition code_of_syscall (fds: funs_data) (name: string) (vs: list eventval) (v: eventval) := + let id := syscall_ident name in + let '(targs, tret, cc) := match fds ! id with + | Some data => (dargs data, dret data, dcc data) + | None => (Tnil, Tvoid, cc_default) + end + in + Scall None (Evar id (Tfunction targs tret cc)) (list_eventval_to_list_expr vs). Definition code_of_return (cp cp': compartment) (v: eventval) := Sreturn (Some (eventval_to_expr v)). @@ -476,11 +488,12 @@ Section Backtranslation. | 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 fds cp cp' id vs - | Event_syscall name vs v => code_of_syscall name vs v + | Event_syscall name vs v => code_of_syscall fds name vs v | Event_return cp cp' v => code_of_return cp cp' v end. (* A while(1)-loop with a big switch inside it *) + (* TODO: needs to distinguish intra/cross syscall *) Definition code_of_trace (fds: funs_data) (t: trace) cnt: statement := Swhile (Econst_int Int.one (Tint I32 Signed noattr)) (switch cnt (map (code_of_event fds) t) (Sreturn None)). @@ -658,6 +671,11 @@ Section Backtranslation. unfold Tptr in *. destruct Archi.ptr64; simpl; auto. Qed. + End CODEPROP. + + + Section STEPPROP. + Variable sid: string -> ident. (* Step lemmas *) Lemma code_of_event_step_vload @@ -675,7 +693,7 @@ Section Backtranslation. (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) rv) : Star (Clight.semantics1 p) - (State f (code_of_event (from_cl_funs_data p) ev) k e le m) + (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) (ev :: nil) (State f Sskip k e le m). Proof. @@ -710,7 +728,7 @@ Section Backtranslation. (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) (Val.load_result ch vv)) : Star (Clight.semantics1 p) - (State f (code_of_event (from_cl_funs_data p) ev) k e le m) + (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) (ev :: nil) (State f Sskip k e le m). Proof. @@ -746,7 +764,7 @@ Section Backtranslation. (ESM: eventval_list_match (globalenv p) vs targs vargs) : Star (Clight.semantics1 p) - (State f (code_of_event (from_cl_funs_data p) ev) k e le m) + (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) (ev :: nil) (State f Sskip k e le m). Proof. @@ -787,7 +805,7 @@ Section Backtranslation. (SIGARGS: data.(dargs) = (list_typ_to_typelist some_sig_args)) : Star (Clight.semantics1 p) - (State f (code_of_event (from_cl_funs_data p) ev) k e le m) + (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) (ev :: nil) (Callstate fd (list_eventval_to_list_val ge vs) (Kcall None f e le k) m). Proof. @@ -832,7 +850,7 @@ Section Backtranslation. (FREE: Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m') : Star (Clight.semantics1 p) - (State f (code_of_event (from_cl_funs_data p) ev) k e le m) + (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) (ev :: nil) (State f' Sskip k' e' (set_opttemp optid (eventval_to_val ge rv) le') m'). Proof. @@ -902,7 +920,7 @@ Section Backtranslation. econstructor 1. Qed. - End CODEPROP. + End STEPPROP. Section WELLFORMED. @@ -1017,6 +1035,7 @@ Section Backtranslation. : wf_inv_cl ge f k e m (Event_return cp cp' rv :: t). + (* TODO: external call - 2 cases: cross-comp, intra-comp -- diff event, code *) Definition wf_st_call_external (ge: genv) (vs: list eventval) k m sname sargs svr ef m1 := let sev := Event_syscall sname sargs svr in From d5c0532135f1467b6739cbf5faa3c4ed1d8d3823 Mon Sep 17 00:00:00 2001 From: ldj Date: Sun, 23 Apr 2023 17:27:47 +0200 Subject: [PATCH 026/174] WIP --- security/Backtranslation.v | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 018121a412..7eccf1917b 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -468,7 +468,9 @@ Section Backtranslation. 2. intra-compartment. need to execute a 'Scall'. We define this case. *) (** need function: external call name -> id **) - (** need axiom: 'Event_syscall name _ _' can be uniquely converted into an ident. **) + (** need axiom: 'Event_syscall name _ _' can be uniquely converted into a code (ident). + e.g., an external call to 'EF_external name _ _' invokes 'Event_syscall name _ _'. + **) Variable syscall_ident: string -> ident. Definition code_of_syscall (fds: funs_data) (name: string) (vs: list eventval) (v: eventval) := let id := syscall_ident name in @@ -494,8 +496,8 @@ Section Backtranslation. (* A while(1)-loop with a big switch inside it *) (* TODO: needs to distinguish intra/cross syscall *) - Definition code_of_trace (fds: funs_data) (t: trace) cnt: statement := - Swhile (Econst_int Int.one (Tint I32 Signed noattr)) (switch cnt (map (code_of_event fds) t) (Sreturn None)). + (* Definition code_of_trace (fds: funs_data) (t: trace) cnt: statement := *) + (* Swhile (Econst_int Int.one (Tint I32 Signed noattr)) (switch cnt (map (code_of_event fds) t) (Sreturn None)). *) End CODE. From 8a5cad75914d776149bc33b149bed4af69e3ad59 Mon Sep 17 00:00:00 2001 From: ldj Date: Sun, 23 Apr 2023 20:37:17 +0200 Subject: [PATCH 027/174] WIP --- security/Backtranslation.v | 129 ++++++++++++++++++++++++++++++++++--- 1 file changed, 119 insertions(+), 10 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 7eccf1917b..99a0a77e66 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -673,6 +673,27 @@ Section Backtranslation. 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. + End CODEPROP. @@ -895,7 +916,7 @@ Section Backtranslation. econstructor 1. Qed. - Lemma code_of_event_step_call_external + Lemma code_of_event_step_call_external_cross p m ge (GE: ge = globalenv p) @@ -922,6 +943,103 @@ Section Backtranslation. econstructor 1. Qed. + Lemma code_of_event_step_return_external_cross + p m + ge + (GE: ge = globalenv p) + ev rv f cp + (EV: ev = Event_return (comp_of f) cp rv) + (* bt should ensure them *) + (* asm should ensure them *) + vres optid e le k ty + (CROSS: Genv.type_of_call ge (comp_of f) cp = Genv.CrossCompartmentCall) + (NPTR: not_ptr vres) + (EM: eventval_match ge rv (proj_rettype ty) vres) + (* handle during proving *) + : + Star (Clight.semantics1 p) + (Returnstate vres (Kcall optid f e le k) m ty cp) + (ev :: nil) + (State f Sskip k e (set_opttemp optid vres le) m). + Proof. + subst; simpl. + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_returnstate; eauto. econstructor 2; eauto. } + econstructor 1. + Qed. + + (* TODO: TYARGS condition needs fix? *) + Lemma code_of_event_step_call_external_intra + ev + name args rv + p f k e le m + ge data + (GE: ge = globalenv p) + (EV: ev = Event_syscall name args rv) + (* start call *) + id + (ID: sid name = id) + (FDATA: (from_cl_funs_data p) ! id = Some data) + (* bt_wf *) + (GLOB: e ! id = None) + (WFARGS1: Forall (wf_eventval_env e) args) + (WFARGS2: Forall (wf_eventval_ge ge) args) + (* from_asm *) + b + (FINDB: Genv.find_symbol ge id = Some b) + (ALLOW: Genv.allowed_call ge (comp_of f) (Vptr b Ptrofs.zero)) + fd + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (TYPEF: type_of_fundef fd = Tfunction data.(dargs) data.(dret) data.(dcc)) + cp cp' + (CP1: cp = comp_of f) + (CP2: cp' = comp_of fd) + (INTRA: Genv.type_of_call ge (comp_of f) (comp_of fd) <> Genv.CrossCompartmentCall) + (* invoke syscall *) + ef cp'' sg + (EF: ef = EF_external name cp'' sg) + (EXTERNAL: fd = External ef data.(dargs) data.(dret) data.(dcc)) + srv m' + (SEM: external_call ef ge cp (list_eventval_to_list_val (globalenv p) args) m (ev :: nil) srv m') + (* returnstate *) + (TYARGS: data.(dargs) = (list_eventval_to_typelist args)) + : + Star (Clight.semantics1 p) + (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) + (ev :: nil) + (State f Sskip k e le m'). + Proof. + subst; simpl. unfold code_of_syscall. rewrite FDATA. + econstructor 2. + 3:{ rewrite E0_left. reflexivity. } + { eapply step_call. simpl; eauto. + { eapply eval_Elvalue. + - eapply eval_Evar_global; eauto. + - eapply deref_loc_reference. auto. + } + { rewrite TYARGS. eapply list_eventval_to_expr_val_eval2; auto. } + all: simpl in *; eauto. + { unfold Genv.find_comp. unfold Genv.find_funct. + rewrite pred_dec_true; auto. rewrite pred_dec_true in FINDF; auto. + rewrite FINDF. intros. exfalso. apply INTRA. auto. + } + { econstructor 1. unfold Genv.find_comp. unfold Genv.find_funct. + rewrite pred_dec_true; auto. rewrite pred_dec_true in FINDF; auto. + rewrite FINDF. intros H. apply INTRA. auto. + } + } + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_external_function. eauto. } + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_returnstate. intro. exfalso. apply INTRA. auto. + econstructor 1. intros H. apply INTRA. auto. + } + econstructor 1. + Qed. + End STEPPROP. @@ -1039,15 +1157,6 @@ Section Backtranslation. (* TODO: external call - 2 cases: cross-comp, intra-comp -- diff event, code *) - Definition wf_st_call_external (ge: genv) (vs: list eventval) k m sname sargs svr ef m1 := - let sev := Event_syscall sname sargs svr in - exists vres, (external_call ef ge (call_comp k) (list_eventval_to_list_val ge vs) m (sev :: nil) vres m1). - - - - - . - (* TODO *) (* we need a more precise invariant for the proof, e.g. counters, mem_inj *) From d2a4ef2bb6d99225e8c79b9cf48660c5fa468ed1 Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 24 Apr 2023 18:13:58 +0200 Subject: [PATCH 028/174] WIP --- security/Backtranslation.v | 237 ++++++++++++++++++++++++++----------- 1 file changed, 166 insertions(+), 71 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 99a0a77e66..a8897bc0ae 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -66,22 +66,23 @@ forall b, b is the block of one of the counter -> (forall b0 ofs, ~ (f b0 = Some (b, ofs))) *) - (* (** External calls must commute with memory injections, *) - (* in the following sense. *) *) - (* ec_mem_inject: *) - (* forall ge1 ge2 c vargs m1 t vres m2 f m1' vargs', *) - (* symbols_inject f ge1 ge2 -> *) - (* sem ge1 c vargs m1 t vres m2 -> *) - (* Mem.inject f m1 m1' -> *) - (* Val.inject_list f vargs vargs' -> *) - (* exists f', exists vres', exists m2', *) - (* sem ge2 c vargs' m1' t vres' m2' *) - (* /\ Val.inject f' vres vres' *) - (* /\ Mem.inject f' m2 m2' *) - (* /\ Mem.unchanged_on (loc_unmapped f) m1 m2 *) - (* /\ Mem.unchanged_on (loc_out_of_reach f m1) m1' m2' *) - (* /\ inject_incr f f' *) - (* /\ inject_separated f f' m1 m1'; *) +(** Events.v **) +(* (** External calls must commute with memory injections, *) +(* in the following sense. *) *) +(* ec_mem_inject: *) +(* forall ge1 ge2 c vargs m1 t vres m2 f m1' vargs', *) +(* symbols_inject f ge1 ge2 -> *) +(* sem ge1 c vargs m1 t vres m2 -> *) +(* Mem.inject f m1 m1' -> *) +(* Val.inject_list f vargs vargs' -> *) +(* exists f', exists vres', exists m2', *) +(* sem ge2 c vargs' m1' t vres' m2' *) +(* /\ Val.inject f' vres vres' *) +(* /\ Mem.inject f' m2 m2' *) +(* /\ Mem.unchanged_on (loc_unmapped f) m1 m2 *) +(* /\ Mem.unchanged_on (loc_out_of_reach f m1) m1' m2' *) +(* /\ inject_incr f f' *) +(* /\ inject_separated f f' m1 m1'; *) End AUX. @@ -106,8 +107,6 @@ Section Backtranslation. Ltac take_step := econstructor; [econstructor; simpl_expr | | traceEq]; simpl. - (* Variable bt_env: backtranslation_environment. *) - Section SWITCH. (** switch statement; use to convert a trace to a code **) @@ -138,7 +137,6 @@ Section Backtranslation. let ge := globalenv p in e ! cnt = None -> Genv.find_symbol ge cnt = Some b -> - (* e ! cnt = Some (b, type_counter) -> *) 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 @@ -229,7 +227,6 @@ Section Backtranslation. let cp := comp_of f in e ! cnt = None -> Genv.find_symbol ge cnt = Some b -> - (* e ! (bt_env.(local_counter) cp) = Some (b, type_counter) -> *) 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', @@ -371,7 +368,7 @@ Section Backtranslation. Section CODEAUX. (* We extract function data: argument types, fn_return, rn_callconv from signature of Asm.function *) - (* Coreectness should follow from the semantics of Asm, especially eventval_match *) + (* Correctness should follow from the semantics of Asm, especially eventval_match *) Definition typ_to_type: typ -> type := fun t: typ => match t with @@ -379,7 +376,7 @@ Section Backtranslation. | AST.Tfloat => Tfloat F64 noattr | AST.Tlong => Tlong Signed noattr | AST.Tsingle => Tfloat F32 noattr - (* will not appear in well formed traces *) + (* not appear in eventval_match *) | AST.Tany32 => Tvoid | AST.Tany64 => Tvoid end. @@ -463,6 +460,11 @@ Section Backtranslation. in Scall None (Evar id (Tfunction targs tret cc)) (list_eventval_to_list_expr vs). + (* TODO: syscall_ident should have more information to distinguish below cases: + | EF_external name _ sg => external_functions_sem name sg + | EF_builtin name sg | EF_runtime name sg => builtin_or_external_sem name sg + | EF_inline_asm txt sg _ => inline_assembly_sem txt sg + *) (* Two cases for invoking an Event_syscall: 1. cross-compartment. follows a call event, so just a skip is enough. 2. intra-compartment. need to execute a 'Scall'. We define this case. @@ -544,6 +546,16 @@ Section Backtranslation. induction EM; simpl. constructor. constructor; auto. eapply eventval_match_transl; eauto. Qed. + Lemma eventval_list_match_transl_val + F V (ge: Genv.t F V) + 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 F V (ge: Genv.t F V) ev ty v @@ -694,6 +706,36 @@ Section Backtranslation. apply sem_cast_eventval; auto. Qed. + Lemma eventval_match_sem_cast + (* F V (ge: Genv.t F V) *) + (ge: cgenv) + 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. + End CODEPROP. @@ -969,7 +1011,6 @@ Section Backtranslation. econstructor 1. Qed. - (* TODO: TYARGS condition needs fix? *) Lemma code_of_event_step_call_external_intra ev name args rv @@ -1003,7 +1044,11 @@ Section Backtranslation. srv m' (SEM: external_call ef ge cp (list_eventval_to_list_val (globalenv p) args) m (ev :: nil) srv m') (* returnstate *) - (TYARGS: data.(dargs) = (list_eventval_to_typelist args)) + (* conditions for argument types - might need extra semantics for EF_external *) + (* (TYARGS: data.(dargs) = (list_eventval_to_typelist args)) *) + some_sig_args some_vals + (ESM: eventval_list_match ge args some_sig_args some_vals) + (SIGARGS: data.(dargs) = (list_typ_to_typelist some_sig_args)) : Star (Clight.semantics1 p) (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) @@ -1018,7 +1063,10 @@ Section Backtranslation. - eapply eval_Evar_global; eauto. - eapply deref_loc_reference. auto. } - { rewrite TYARGS. eapply list_eventval_to_expr_val_eval2; auto. } + (* { rewrite TYARGS. eapply list_eventval_to_expr_val_eval2; auto. } *) + { rewrite SIGARGS. instantiate (1:=list_eventval_to_list_val (globalenv p) args). + eapply list_eventval_to_expr_val_eval_typs; auto. eapply eventval_list_match_transl_val; eauto. + } all: simpl in *; eauto. { unfold Genv.find_comp. unfold Genv.find_funct. rewrite pred_dec_true; auto. rewrite pred_dec_true in FINDF; auto. @@ -1043,6 +1091,21 @@ Section Backtranslation. End STEPPROP. + Record syscall_properties (sem: extcall_sem) (sg: signature) : Prop := + mk_syscall_properties { + sc_args_match: + forall ge cp vargs m1 name evargs evres vres m2, + sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> + eventval_list_match ge evargs sg.(sig_args) vargs; + + sc_name_match: + forall name' ge cp vargs m1 name evargs evres vres m2, + sem = external_functions_sem name' sg -> + sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> + (name' = name); + }. + + Section WELLFORMED. Definition empty_le := PTree.empty val. @@ -1082,16 +1145,12 @@ Section Backtranslation. (eventval_list_match ge vs some_sig_args some_vals) /\ (data.(dargs) = (list_typ_to_typelist some_sig_args)). - Definition wf_st_call_start (cp cp': compartment) (id: ident) (vs: list eventval) e (f: Clight.function) := - (e ! id = None) /\ (Forall (wf_eventval_env e) vs) /\ (cp = comp_of f). + Definition wf_st_call_start (cp cp': compartment) (id: ident) (vs: list eventval) e (f: Clight.function) k k' := + (e ! id = None) /\ (Forall (wf_eventval_env e) vs) /\ (cp = comp_of f) /\ (k' = Kcall None f e empty_le k). Definition wf_st_call_internal (ge: genv) (vs: list eventval) (f1: Clight.function) m e1 m1 := function_entry1 ge f1 (list_eventval_to_list_val ge vs) m e1 empty_le m1. - Definition wf_st_call_external (ge: genv) (vs: list eventval) k m sname sargs svr ef m1 := - let sev := Event_syscall sname sargs svr in - exists vres, (external_call ef ge (call_comp k) (list_eventval_to_list_val ge vs) m (sev :: nil) vres m1). - Definition wf_sem_return {F V} (ge: Genv.t F V) (cp cp': compartment) (rv: eventval) := (Genv.type_of_call ge cp' cp = Genv.CrossCompartmentCall) /\ (not_ptr (eventval_to_val ge rv)) /\ @@ -1106,6 +1165,16 @@ Section Backtranslation. (cp' = comp_of f') /\ (Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m'). + Definition wf_st_call_external_cross (ge: genv) (vs: list eventval) k m sname sargs svr ef m1 vres := + let sev := Event_syscall sname sargs svr in + (external_call ef ge (call_comp k) (list_eventval_to_list_val ge vs) m (sev :: nil) vres m1). + + Definition wf_st_return_external_cross (ge: genv) (cp_f' cp: compartment) vres (rv: eventval) ty (k: cont) f' k' e' := + (k = Kcall None f' e' empty_le k') /\ + (cp_f' = comp_of f') /\ + (Genv.type_of_call ge cp_f' cp = Genv.CrossCompartmentCall) /\ + (not_ptr vres) /\ (eventval_match ge rv (proj_rettype ty) vres). + Inductive wf_inv_cl (ge: genv) : Clight.function -> cont -> env -> mem -> trace -> Prop := | wf_inv_vload @@ -1138,11 +1207,12 @@ Section Backtranslation. cp cp' id vs fd (SEM: wf_sem_call_start_cl ge cp cp' id vs fd) - (ST: wf_st_call_start cp cp' id vs e f) + k1 + (ST: wf_st_call_start cp cp' id vs e f k k1) f1 e1 m1 (ISINT: fd = Internal f1) (INT: wf_st_call_internal ge vs f1 m e1 m1) - (IND: wf_inv_cl ge f1 (Kcall None f e empty_le k) e1 m1 t) + (IND: wf_inv_cl ge f1 k1 e1 m1 t) : wf_inv_cl ge f k e m (Event_call cp cp' id vs :: t) | wf_inv_return @@ -1153,52 +1223,77 @@ Section Backtranslation. (ST: wf_st_return ge cp cp' rv e f k m f' k' e' m') (IND: wf_inv_cl ge f' k' e' m' t) : - wf_inv_cl ge f k e m (Event_return cp cp' rv :: t). + wf_inv_cl ge f k e m (Event_return cp cp' rv :: t) + + | wf_inv_external_cross + f k e m t + cp cp' id vs + fd + (SEM: wf_sem_call_start_cl ge cp cp' id vs fd) + k1 + (ST: wf_st_call_start cp cp' id vs e f k k1) + ef targs tres cconv + (ISEXT: fd = External ef targs tres cconv) + sname sargs svr m' vres + (EXT1: wf_st_call_external_cross ge vs k1 m sname sargs svr ef m' vres) + cp_f' cp_ef evres + f' k' e' + (EXT2: wf_st_return_external_cross ge cp_f' (comp_of ef) vres evres (rettype_of_type tres) k1 f' k' e') + (IND: wf_inv_cl ge f' k' e' m' t) + : + wf_inv_cl ge f k e m ((Event_call cp cp' id vs) :: (Event_syscall sname sargs svr) :: (Event_return cp_f' cp_ef evres) :: t) + . (* TODO: external call - 2 cases: cross-comp, intra-comp -- diff event, code *) (* TODO *) (* we need a more precise invariant for the proof, e.g. counters, mem_inj *) + Lemma code_of_event_step_call_external_intra + ev + name args rv + p f k e le m + ge data + (GE: ge = globalenv p) + (EV: ev = Event_syscall name args rv) + (* start call *) + id + (ID: sid name = id) + (FDATA: (from_cl_funs_data p) ! id = Some data) + (* bt_wf *) + (GLOB: e ! id = None) + (WFARGS1: Forall (wf_eventval_env e) args) + (WFARGS2: Forall (wf_eventval_ge ge) args) + (* from_asm *) + b + (FINDB: Genv.find_symbol ge id = Some b) + (ALLOW: Genv.allowed_call ge (comp_of f) (Vptr b Ptrofs.zero)) + fd + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (TYPEF: type_of_fundef fd = Tfunction data.(dargs) data.(dret) data.(dcc)) + cp cp' + (CP1: cp = comp_of f) + (CP2: cp' = comp_of fd) + (INTRA: Genv.type_of_call ge (comp_of f) (comp_of fd) <> Genv.CrossCompartmentCall) + (* invoke syscall *) + ef cp'' sg + (EF: ef = EF_external name cp'' sg) + (EXTERNAL: fd = External ef data.(dargs) data.(dret) data.(dcc)) + srv m' + (SEM: external_call ef ge cp (list_eventval_to_list_val (globalenv p) args) m (ev :: nil) srv m') + (* returnstate *) + (* conditions for argument types - might need extra semantics for EF_external *) + (* (TYARGS: data.(dargs) = (list_eventval_to_typelist args)) *) + some_sig_args some_vals + (ESM: eventval_list_match ge args some_sig_args some_vals) + (SIGARGS: data.(dargs) = (list_typ_to_typelist some_sig_args)) + : + Star (Clight.semantics1 p) + (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) + (ev :: nil) + (State f Sskip k e le m'). -(** Events.v **) -(* (** External calls must commute with memory injections, *) -(* in the following sense. *) *) -(* ec_mem_inject: *) -(* forall ge1 ge2 c vargs m1 t vres m2 f m1' vargs', *) -(* symbols_inject f ge1 ge2 -> *) -(* sem ge1 c vargs m1 t vres m2 -> *) -(* Mem.inject f m1 m1' -> *) -(* Val.inject_list f vargs vargs' -> *) -(* exists f', exists vres', exists m2', *) -(* sem ge2 c vargs' m1' t vres' m2' *) -(* /\ Val.inject f' vres vres' *) -(* /\ Mem.inject f' m2 m2' *) -(* /\ Mem.unchanged_on (loc_unmapped f) m1 m2 *) -(* /\ Mem.unchanged_on (loc_out_of_reach f m1) m1' m2' *) -(* /\ inject_incr f f' *) -(* /\ inject_separated f f' m1 m1'; *) - - (* Lemma code_of_event_step_call_external *) - (* p m *) - (* ge *) - (* (GE: ge = globalenv p) *) - (* (* bt should ensure them *) *) - (* fd k args ef targs tres cconv *) - (* (EXTERNAL: fd = External ef targs tres cconv) *) - (* (* asm should ensure them *) *) - (* sev *) - (* vres m1 *) - (* (SEM: external_call ef ge (call_comp k) args m (sev :: nil) vres m1) *) - (* (* handle during proving *) *) - (* sname sargs svr *) - (* (SYSEV: sev = Event_syscall sname sargs svr) *) - (* : *) - (* Star (Clight.semantics1 p) *) - (* (Callstate fd args k m) *) - (* (sev :: nil) *) - (* (Returnstate vres k m1 (rettype_of_type tres) (comp_of ef)). *) End WELLFORMED. From cff1d64f0c70907544d8d566d126bb63ac9b08ef Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 25 Apr 2023 18:10:25 +0200 Subject: [PATCH 029/174] WIP --- security/Backtranslation.v | 207 ++++++++++++++++++++----------------- 1 file changed, 112 insertions(+), 95 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index a8897bc0ae..38dd8af27a 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -9,6 +9,64 @@ Require Import Ctypes Clight. +Definition eventval_to_val (ge: Senv.t) (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 ge (vs: list eventval): list val := + List.map (eventval_to_val ge) vs. + +(* need to handle type: It seems that Asm.step does not utilizes sig, so we need to correctly craft type in Clight.step. + e.g., if we bt everything into void, ok when intra but not when cross. +*) +Definition syscall_properties1 (sem: extcall_sem) : Prop := + forall ge cp vargs m1 name evargs evres vres m2, + sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> + exists vres' m2', + sem ge cp (list_eventval_to_list_val ge evargs) m1 (Event_syscall name evargs evres :: nil) vres' m2'. + +Definition syscall_properties2 (sem: extcall_sem) (sg: signature) : Prop := + forall ge cp vargs m1 name evargs evres vres m2, + sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> + eventval_list_match ge evargs sg.(sig_args) vargs. + +(* Record syscall_properties1 (sem: extcall_sem) (sg: signature) : Prop := *) +(* mk_syscall_properties { *) +(* sc_args_match: *) +(* forall ge cp vargs m1 name evargs evres vres m2, *) +(* sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> *) +(* sem ge cp (list_eventval_to_list_val ge vargs) m1 (Event_syscall name evargs evres :: nil) vres m2; *) + +(* sc_name_match: *) +(* forall name' ge cp vargs m1 name evargs evres vres m2, *) +(* sem = external_functions_sem name' sg -> *) +(* sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> *) +(* (name' = name); *) +(* }. *) + +(* Record syscall_properties2 (sem: extcall_sem) (sg: signature) : Prop := *) +(* mk_syscall_properties { *) +(* sc_args_match: *) +(* forall ge cp vargs m1 name evargs evres vres m2, *) +(* sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> *) +(* eventval_list_match ge evargs sg.(sig_args) vargs; *) + +(* sc_name_match: *) +(* forall name' ge cp vargs m1 name evargs evres vres m2, *) +(* sem = external_functions_sem name' sg -> *) +(* sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> *) +(* (name' = name); *) +(* }. *) + + Section AUX. (* f doesn't map anything to [b], e.g. the counter and function parameters *) @@ -332,18 +390,6 @@ Section Backtranslation. wf_eventval_pub v -> wf_eventval_ge v. Proof. intros H. destruct v; simpl in *; auto. apply Genv.public_symbol_exists in H; auto. Qed. - 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. - Fixpoint list_eventval_to_typelist (vs: list eventval): typelist := match vs with | nil => Tnil @@ -353,9 +399,6 @@ Section Backtranslation. Definition list_eventval_to_list_expr (vs: list eventval): list expr := List.map eventval_to_expr vs. - Definition list_eventval_to_list_val (vs: list eventval): list val := - List.map (eventval_to_val) vs. - Lemma typeof_eventval_to_expr_type v : @@ -1025,7 +1068,7 @@ Section Backtranslation. (* bt_wf *) (GLOB: e ! id = None) (WFARGS1: Forall (wf_eventval_env e) args) - (WFARGS2: Forall (wf_eventval_ge ge) args) + (* (WFARGS2: Forall (wf_eventval_ge ge) args) *) (* from_asm *) b (FINDB: Genv.find_symbol ge id = Some b) @@ -1038,8 +1081,8 @@ Section Backtranslation. (CP2: cp' = comp_of fd) (INTRA: Genv.type_of_call ge (comp_of f) (comp_of fd) <> Genv.CrossCompartmentCall) (* invoke syscall *) - ef cp'' sg - (EF: ef = EF_external name cp'' sg) + ef name' cp'' sg + (EF: ef = EF_external name' cp'' sg) (EXTERNAL: fd = External ef data.(dargs) data.(dret) data.(dcc)) srv m' (SEM: external_call ef ge cp (list_eventval_to_list_val (globalenv p) args) m (ev :: nil) srv m') @@ -1091,21 +1134,6 @@ Section Backtranslation. End STEPPROP. - Record syscall_properties (sem: extcall_sem) (sg: signature) : Prop := - mk_syscall_properties { - sc_args_match: - forall ge cp vargs m1 name evargs evres vres m2, - sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> - eventval_list_match ge evargs sg.(sig_args) vargs; - - sc_name_match: - forall name' ge cp vargs m1 name evargs evres vres m2, - sem = external_functions_sem name' sg -> - sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> - (name' = name); - }. - - Section WELLFORMED. Definition empty_le := PTree.empty val. @@ -1175,32 +1203,55 @@ Section Backtranslation. (Genv.type_of_call ge cp_f' cp = Genv.CrossCompartmentCall) /\ (not_ptr vres) /\ (eventval_match ge rv (proj_rettype ty) vres). - - Inductive wf_inv_cl (ge: genv) : Clight.function -> cont -> env -> mem -> trace -> Prop := + Definition wf_sem_call_external_intra (ge: genv) (name: string) (evargs: list eventval) (evres: eventval) (id: ident) (f: Clight.function) (fd: Clight.fundef) := + exists b, + (Genv.find_symbol ge id = Some b) /\ + (Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) /\ + let data := from_clfd_fun_data fd in + (type_of_fundef fd = Tfunction data.(dargs) data.(dret) data.(dcc)) /\ + let cp := comp_of f in + let cp' := comp_of fd in + (Genv.type_of_call ge cp cp' <> Genv.CrossCompartmentCall) /\ + (Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) /\ + exists some_sig_args some_vals, + (eventval_list_match ge evargs some_sig_args some_vals) /\ + (data.(dargs) = (list_typ_to_typelist some_sig_args)). + + Definition wf_st_call_external_intra (ge: genv) (name: string) (evargs: list eventval) (evres: eventval) (id: ident) (f: Clight.function) e := + (e ! id = None) /\ (Forall (wf_eventval_env e) evargs). + + Definition wf_sem_event_external_intra (ge: genv) (name: string) (evargs: list eventval) (evres: eventval) cp (ef: external_function) m m' := + exists name' cp' sg', + (* TODO: fix to incldue builtin, runtime, inline_asm *) + (ef = EF_external name' cp' sg') /\ + exists res, + (external_call ef ge cp (list_eventval_to_list_val ge evargs) m (Event_syscall name evargs evres :: nil) res m'). + + Inductive wf_inv_cl (ge: genv) (sid: string -> ident) : Clight.function -> cont -> env -> mem -> trace -> Prop := | wf_inv_vload f k e m t ch id ofs v (SEM: wf_sem_vload ge ch id ofs v) (ST: wf_st_vload ch id ofs v e) - (IND: wf_inv_cl ge f k e m t) + (IND: wf_inv_cl ge sid f k e m t) : - wf_inv_cl ge f k e m (Event_vload ch id ofs v :: t) + wf_inv_cl ge sid f k e m (Event_vload ch id ofs v :: t) | wf_inv_vstore f k e m t ch id ofs v (SEM: wf_sem_vstore ge ch id ofs v) (ST: wf_st_vstore ch id ofs v e) - (IND: wf_inv_cl ge f k e m t) + (IND: wf_inv_cl ge sid f k e m t) : - wf_inv_cl ge f k e m (Event_vstore ch id ofs v :: t) + wf_inv_cl ge sid f k e m (Event_vstore ch id ofs v :: t) | wf_inv_annot f k e m t str vs (SEM: wf_sem_annot ge str vs) (ST: wf_st_annot str vs e) - (IND: wf_inv_cl ge f k e m t) + (IND: wf_inv_cl ge sid f k e m t) : - wf_inv_cl ge f k e m (Event_annot str vs :: t) + wf_inv_cl ge sid f k e m (Event_annot str vs :: t) | wf_inv_call_internal f k e m t @@ -1212,18 +1263,18 @@ Section Backtranslation. f1 e1 m1 (ISINT: fd = Internal f1) (INT: wf_st_call_internal ge vs f1 m e1 m1) - (IND: wf_inv_cl ge f1 k1 e1 m1 t) + (IND: wf_inv_cl ge sid f1 k1 e1 m1 t) : - wf_inv_cl ge f k e m (Event_call cp cp' id vs :: t) + wf_inv_cl ge sid f k e m (Event_call cp cp' id vs :: t) | wf_inv_return f k e m t cp cp' rv (SEM: wf_sem_return ge cp cp' rv) f' k' e' m' (ST: wf_st_return ge cp cp' rv e f k m f' k' e' m') - (IND: wf_inv_cl ge f' k' e' m' t) + (IND: wf_inv_cl ge sid f' k' e' m' t) : - wf_inv_cl ge f k e m (Event_return cp cp' rv :: t) + wf_inv_cl ge sid f k e m (Event_return cp cp' rv :: t) | wf_inv_external_cross f k e m t @@ -1239,62 +1290,28 @@ Section Backtranslation. cp_f' cp_ef evres f' k' e' (EXT2: wf_st_return_external_cross ge cp_f' (comp_of ef) vres evres (rettype_of_type tres) k1 f' k' e') - (IND: wf_inv_cl ge f' k' e' m' t) + (IND: wf_inv_cl ge sid f' k' e' m' t) : - wf_inv_cl ge f k e m ((Event_call cp cp' id vs) :: (Event_syscall sname sargs svr) :: (Event_return cp_f' cp_ef evres) :: t) - . + wf_inv_cl ge sid f k e m ((Event_call cp cp' id vs) :: (Event_syscall sname sargs svr) :: (Event_return cp_f' cp_ef evres) :: t) - (* TODO: external call - 2 cases: cross-comp, intra-comp -- diff event, code *) + | wf_inv_external_intra + f k e m t + name evargs evres + fd + (SEM: wf_sem_call_external_intra ge name evargs evres (sid name) f fd) + (ST: wf_st_call_external_intra ge name evargs evres (sid name) f e) + ef targs tres cconv + (ISEXT: fd = External ef targs tres cconv) + m' + (EXT: wf_sem_event_external_intra ge name evargs evres (comp_of f) ef m m') + (IND: wf_inv_cl ge sid f k e m' t) + : + wf_inv_cl ge sid f k e m (Event_syscall name evargs evres :: t) + . (* TODO *) (* we need a more precise invariant for the proof, e.g. counters, mem_inj *) - Lemma code_of_event_step_call_external_intra - ev - name args rv - p f k e le m - ge data - (GE: ge = globalenv p) - (EV: ev = Event_syscall name args rv) - (* start call *) - id - (ID: sid name = id) - (FDATA: (from_cl_funs_data p) ! id = Some data) - (* bt_wf *) - (GLOB: e ! id = None) - (WFARGS1: Forall (wf_eventval_env e) args) - (WFARGS2: Forall (wf_eventval_ge ge) args) - (* from_asm *) - b - (FINDB: Genv.find_symbol ge id = Some b) - (ALLOW: Genv.allowed_call ge (comp_of f) (Vptr b Ptrofs.zero)) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (TYPEF: type_of_fundef fd = Tfunction data.(dargs) data.(dret) data.(dcc)) - cp cp' - (CP1: cp = comp_of f) - (CP2: cp' = comp_of fd) - (INTRA: Genv.type_of_call ge (comp_of f) (comp_of fd) <> Genv.CrossCompartmentCall) - (* invoke syscall *) - ef cp'' sg - (EF: ef = EF_external name cp'' sg) - (EXTERNAL: fd = External ef data.(dargs) data.(dret) data.(dcc)) - srv m' - (SEM: external_call ef ge cp (list_eventval_to_list_val (globalenv p) args) m (ev :: nil) srv m') - (* returnstate *) - (* conditions for argument types - might need extra semantics for EF_external *) - (* (TYARGS: data.(dargs) = (list_eventval_to_typelist args)) *) - some_sig_args some_vals - (ESM: eventval_list_match ge args some_sig_args some_vals) - (SIGARGS: data.(dargs) = (list_typ_to_typelist some_sig_args)) - : - Star (Clight.semantics1 p) - (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) - (ev :: nil) - (State f Sskip k e le m'). - - - End WELLFORMED. From 58e1fed241ef35bc526215d33a46403adf19f507 Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 26 Apr 2023 17:08:12 +0200 Subject: [PATCH 030/174] WIP --- security/Backtranslation.v | 139 ++++++++++++++++++++++++++++++++++--- 1 file changed, 128 insertions(+), 11 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 38dd8af27a..6524cb699b 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -9,6 +9,13 @@ Require Import Ctypes Clight. +Variant sys_kind := + | sys_external (id: ident) + | sys_builtin (name: string) (sg: signature) + | sys_inline (txt: string) (sg: signature) (strs: list string) +. + + Definition eventval_to_val (ge: Senv.t) (v: eventval): val := match v with | EVint i => Vint i @@ -516,15 +523,24 @@ Section Backtranslation. (** need axiom: 'Event_syscall name _ _' can be uniquely converted into a code (ident). e.g., an external call to 'EF_external name _ _' invokes 'Event_syscall name _ _'. **) - Variable syscall_ident: string -> ident. + Variable sid: string -> option sys_kind. Definition code_of_syscall (fds: funs_data) (name: string) (vs: list eventval) (v: eventval) := - let id := syscall_ident name in - let '(targs, tret, cc) := match fds ! id with - | Some data => (dargs data, dret data, dcc data) - | None => (Tnil, Tvoid, cc_default) - end - in - Scall None (Evar id (Tfunction targs tret cc)) (list_eventval_to_list_expr vs). + match (sid name) with + | Some (sys_external id) => + let '(targs, tret, cc) := match fds ! id with + | Some data => (dargs data, dret data, dcc data) + | None => (Tnil, Tvoid, cc_default) + end + in + Scall None (Evar id (Tfunction targs tret cc)) (list_eventval_to_list_expr vs) + | Some (sys_builtin name' sg) => + Sbuiltin None (EF_builtin name' sg) (dargs (from_sig_fun_data sg)) (list_eventval_to_list_expr vs) + | Some (sys_inline txt sg strs) => + Sbuiltin None (EF_inline_asm txt sg strs) (dargs (from_sig_fun_data sg)) (list_eventval_to_list_expr vs) + | None => + Sskip + end. + Definition code_of_return (cp cp': compartment) (v: eventval) := Sreturn (Some (eventval_to_expr v)). @@ -783,7 +799,8 @@ Section Backtranslation. Section STEPPROP. - Variable sid: string -> ident. + + Variable sid: string -> option sys_kind. (* Step lemmas *) Lemma code_of_event_step_vload @@ -1054,6 +1071,8 @@ Section Backtranslation. econstructor 1. Qed. + (* TODO: similar to external_cross? *) + Lemma code_of_event_step_call_external_intra ev name args rv @@ -1063,7 +1082,7 @@ Section Backtranslation. (EV: ev = Event_syscall name args rv) (* start call *) id - (ID: sid name = id) + (ID: sid name = Some (sys_external id)) (FDATA: (from_cl_funs_data p) ! id = Some data) (* bt_wf *) (GLOB: e ! id = None) @@ -1098,7 +1117,7 @@ Section Backtranslation. (ev :: nil) (State f Sskip k e le m'). Proof. - subst; simpl. unfold code_of_syscall. rewrite FDATA. + subst; simpl. unfold code_of_syscall. rewrite ID. rewrite FDATA. econstructor 2. 3:{ rewrite E0_left. reflexivity. } { eapply step_call. simpl; eauto. @@ -1131,6 +1150,76 @@ Section Backtranslation. econstructor 1. Qed. + Lemma code_of_event_step_builtin + ev + name args rv + p f k e le m + ge + (GE: ge = globalenv p) + (EV: ev = Event_syscall name args rv) + name' sg + (ID: sid name = Some (sys_builtin name' sg)) + (* bt_wf *) + (WFARGS: Forall (wf_eventval_env e) args) + (* from_asm *) + (* invoke syscall *) + ef + (EF: ef = EF_builtin name' sg) + srv m' + (SEM: external_call ef ge (comp_of f) (list_eventval_to_list_val (globalenv p) args) m (ev :: nil) srv m') + (* conditions for argument types - might need extra semantics for EF_external *) + (* (TYARGS: data.(dargs) = (list_eventval_to_typelist args)) *) + some_sig_args some_vals + (ESM: eventval_list_match ge args some_sig_args some_vals) + (SIGARGS: sg.(sig_args) = (some_sig_args)) + : + Star (Clight.semantics1 p) + (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) + (ev :: nil) + (State f Sskip k e le m'). + Proof. + subst; simpl. unfold code_of_syscall. rewrite ID. + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_builtin; simpl; eauto. eapply list_eventval_to_expr_val_eval_typs; auto. eapply eventval_list_match_transl_val; eauto. } + econstructor 1. + Qed. + + Lemma code_of_event_step_inline + ev + name args rv + p f k e le m + ge + (GE: ge = globalenv p) + (EV: ev = Event_syscall name args rv) + txt sg strs + (ID: sid name = Some (sys_inline txt sg strs)) + (* bt_wf *) + (WFARGS: Forall (wf_eventval_env e) args) + (* from_asm *) + (* invoke syscall *) + ef + (EF: ef = EF_inline_asm txt sg strs) + srv m' + (SEM: external_call ef ge (comp_of f) (list_eventval_to_list_val (globalenv p) args) m (ev :: nil) srv m') + (* conditions for argument types - might need extra semantics for EF_external *) + (* (TYARGS: data.(dargs) = (list_eventval_to_typelist args)) *) + some_sig_args some_vals + (ESM: eventval_list_match ge args some_sig_args some_vals) + (SIGARGS: sg.(sig_args) = (some_sig_args)) + : + Star (Clight.semantics1 p) + (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) + (ev :: nil) + (State f Sskip k e le m'). + Proof. + subst; simpl. unfold code_of_syscall. rewrite ID. + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_builtin; simpl; eauto. eapply list_eventval_to_expr_val_eval_typs; auto. eapply eventval_list_match_transl_val; eauto. } + econstructor 1. + Qed. + End STEPPROP. @@ -1227,6 +1316,34 @@ Section Backtranslation. exists res, (external_call ef ge cp (list_eventval_to_list_val ge evargs) m (Event_syscall name evargs evres :: nil) res m'). + Lemma code_of_event_step_builtin + ev + name args rv + p f k e le m + ge + (GE: ge = globalenv p) + (EV: ev = Event_syscall name args rv) + name' sg + (ID: sid name = Some (sys_builtin name' sg)) + (* bt_wf *) + (WFARGS: Forall (wf_eventval_env e) args) + (* from_asm *) + (* invoke syscall *) + ef + (EF: ef = EF_builtin name' sg) + srv m' + (SEM: external_call ef ge (comp_of f) (list_eventval_to_list_val (globalenv p) args) m (ev :: nil) srv m') + (* conditions for argument types - might need extra semantics for EF_external *) + (* (TYARGS: data.(dargs) = (list_eventval_to_typelist args)) *) + some_sig_args some_vals + (ESM: eventval_list_match ge args some_sig_args some_vals) + (SIGARGS: sg.(sig_args) = (some_sig_args)) + : + Star (Clight.semantics1 p) + (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) + (ev :: nil) + (State f Sskip k e le m'). + Inductive wf_inv_cl (ge: genv) (sid: string -> ident) : Clight.function -> cont -> env -> mem -> trace -> Prop := | wf_inv_vload f k e m t From 03c29fb32bfacf0e9e1089c353424b0dd44fdb72 Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 28 Apr 2023 18:12:09 +0200 Subject: [PATCH 031/174] WIP: informative sem --- security/Backtranslation.v | 230 ++++++++++++++++++++++++++----------- 1 file changed, 164 insertions(+), 66 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 6524cb699b..816ce4d7a9 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -9,69 +9,149 @@ Require Import Ctypes Clight. -Variant sys_kind := - | sys_external (id: ident) - | sys_builtin (name: string) (sg: signature) - | sys_inline (txt: string) (sg: signature) (strs: list string) -. - - -Definition eventval_to_val (ge: Senv.t) (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 ge (vs: list eventval): list val := - List.map (eventval_to_val ge) vs. - -(* need to handle type: It seems that Asm.step does not utilizes sig, so we need to correctly craft type in Clight.step. +Record syscall_properties (sem: extcall_sem) (sg: signature) : Prop := + mk_syscall_properties { + sc_args_match: + forall ge cp args m1 name evargs evres res m2, + sem ge cp args m1 (Event_syscall name evargs evres :: nil) res m2 -> + eventval_list_match ge evargs sg.(sig_args) args; + }. + + +Section GENV. + + Context {F: Type}. + Context {V: Type}. + + (* For NR, use below: *) + (* ::: mkpass Unusedglobproof.match_prog *) + (* match_prog_unique: *) + (* list_norepet (prog_defs_names tp) *) + 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 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. + +End GENV. + + +Section INFORMATIVE. + + (* At CROSS-COMP calls, if fundef is ext, set to is_ext. Otherwise is_not_ext. *) + (* Similar at return. *) + (* When a Event_syscall is is_cross_ext, do not back-translate Event_syscall and the following Event_return. *) + Variant cross_ext := | is_cross_ext | is_not_cross_ext. + + (* TODO: how to make code from block?? *) + (* To get information for inter-comp external calls or builtins *) + Variant sys_kind := + | sys_external (b: block) + | sys_builtin (ef: external_function) + (* | sys_inline (txt: string) (sg: signature) (strs: list string) *) + . + + Definition informative_event := (event * (cross_ext * (option sys_kind)))%type. + Definition informative_trace := list informative_event. + +End INFORMATIVE. + + +Section INFOASM. + + +End INFOASM. + + + +Section EXTFUN. + + (* Requirements for external call semantics and definitions. *) + + + Definition match_sk_ef_asm (ge: Asm.genv) (sk: sys_kind) (ef: external_function) : Prop := + match sk with + | sys_external id => + exists b, (Genv.find_symbol ge id = Some b) /\ (Genv.find_funct ge (Vptr b Ptrofs.zero) = Some (AST.External ef)) + | sys_builtin name sg => + (ef = EF_builtin name sg) \/ (ef = EF_runtime name sg) + | sys_inline txt sg strs => + (ef = EF_inline_asm txt sg strs) + end. + + Definition match_sk_ef_cl (ge: Clight.genv) (sk: sys_kind) (ef: external_function) : Prop := + match sk with + | sys_external id => + exists b, (Genv.find_symbol ge id = Some b) /\ (exists targs tres cc, Genv.find_funct ge (Vptr b Ptrofs.zero) = Some (External ef targs tres cc)) + | sys_builtin name sg => + (ef = EF_builtin name sg) \/ (ef = EF_runtime name sg) + | sys_inline txt sg strs => + (ef = EF_inline_asm txt sg strs) + end. + + Definition sys_env := string -> option sys_kind. + + Definition wf_sys_env_asm (ske: sys_env): Prop := + forall ef (ge: Asm.genv) cp args m name evargs evres res m' + (DEFINED: external_call ef ge cp args m (Event_syscall name evargs evres :: nil) res m'), + exists sk, + (ske name = Some sk) /\ (match_sk_ef_asm ge sk ef). + + + + + (SEM: external_call ef ge cp (list_eventval_to_list_val (globalenv p) args) m (ev :: nil) srv m') + + + + (* need to handle type: It seems that Asm.step does not utilizes sig, so we need to correctly craft type in Clight.step. e.g., if we bt everything into void, ok when intra but not when cross. -*) -Definition syscall_properties1 (sem: extcall_sem) : Prop := - forall ge cp vargs m1 name evargs evres vres m2, - sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> - exists vres' m2', - sem ge cp (list_eventval_to_list_val ge evargs) m1 (Event_syscall name evargs evres :: nil) vres' m2'. - -Definition syscall_properties2 (sem: extcall_sem) (sg: signature) : Prop := - forall ge cp vargs m1 name evargs evres vres m2, - sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> - eventval_list_match ge evargs sg.(sig_args) vargs. - -(* Record syscall_properties1 (sem: extcall_sem) (sg: signature) : Prop := *) -(* mk_syscall_properties { *) -(* sc_args_match: *) -(* forall ge cp vargs m1 name evargs evres vres m2, *) -(* sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> *) -(* sem ge cp (list_eventval_to_list_val ge vargs) m1 (Event_syscall name evargs evres :: nil) vres m2; *) - -(* sc_name_match: *) -(* forall name' ge cp vargs m1 name evargs evres vres m2, *) -(* sem = external_functions_sem name' sg -> *) -(* sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> *) -(* (name' = name); *) -(* }. *) - -(* Record syscall_properties2 (sem: extcall_sem) (sg: signature) : Prop := *) -(* mk_syscall_properties { *) -(* sc_args_match: *) -(* forall ge cp vargs m1 name evargs evres vres m2, *) -(* sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> *) -(* eventval_list_match ge evargs sg.(sig_args) vargs; *) - -(* sc_name_match: *) -(* forall name' ge cp vargs m1 name evargs evres vres m2, *) -(* sem = external_functions_sem name' sg -> *) -(* sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> *) -(* (name' = name); *) -(* }. *) + *) + Definition syscall_properties1 (sem: extcall_sem) : Prop := + forall ge cp vargs m1 name evargs evres vres m2, + sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> + exists vres' m2', + sem ge cp (list_eventval_to_list_val ge evargs) m1 (Event_syscall name evargs evres :: nil) vres' m2'. + + + (* Record syscall_properties1 (sem: extcall_sem) (sg: signature) : Prop := *) + (* mk_syscall_properties { *) + (* sc_args_match: *) + (* forall ge cp vargs m1 name evargs evres vres m2, *) + (* sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> *) + (* sem ge cp (list_eventval_to_list_val ge vargs) m1 (Event_syscall name evargs evres :: nil) vres m2; *) + + (* sc_name_match: *) + (* forall name' ge cp vargs m1 name evargs evres vres m2, *) + (* sem = external_functions_sem name' sg -> *) + (* sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> *) + (* (name' = name); *) + (* }. *) + + (* Record syscall_properties2 (sem: extcall_sem) (sg: signature) : Prop := *) + (* mk_syscall_properties { *) + (* sc_args_match: *) + (* forall ge cp vargs m1 name evargs evres vres m2, *) + (* sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> *) + (* eventval_list_match ge evargs sg.(sig_args) vargs; *) + + (* sc_name_match: *) + (* forall name' ge cp vargs m1 name evargs evres vres m2, *) + (* sem = external_functions_sem name' sg -> *) + (* sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> *) + (* (name' = name); *) + (* }. *) +End EXTFUN. Section AUX. @@ -336,6 +416,21 @@ Section Backtranslation. Definition wf_env (e: env) id := e ! id = None. + Definition eventval_to_val (ge: Senv.t) (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 ge (vs: list eventval): list val := + List.map (eventval_to_val ge) vs. + Definition eventval_to_type (v: eventval): type := match v with | EVint _ => Tint I32 Signed noattr @@ -471,8 +566,10 @@ Section Backtranslation. (* 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 _ tps tr cc => mkfundata tps tr cc end. *) Definition from_clfd_fun_data (fd: Clight.fundef): fun_data := - match fd with | Ctypes.Internal cf => from_clfun_fun_data cf | Ctypes.External _ tps tr cc => mkfundata tps tr cc end. + 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. @@ -1071,8 +1168,8 @@ Section Backtranslation. econstructor 1. Qed. - (* TODO: similar to external_cross? *) + (* TODO *) Lemma code_of_event_step_call_external_intra ev name args rv @@ -1100,8 +1197,9 @@ Section Backtranslation. (CP2: cp' = comp_of fd) (INTRA: Genv.type_of_call ge (comp_of f) (comp_of fd) <> Genv.CrossCompartmentCall) (* invoke syscall *) - ef name' cp'' sg - (EF: ef = EF_external name' cp'' sg) + ef + (* name' cp'' sg *) + (* (EF: ef = EF_external name' cp'' sg) *) (EXTERNAL: fd = External ef data.(dargs) data.(dret) data.(dcc)) srv m' (SEM: external_call ef ge cp (list_eventval_to_list_val (globalenv p) args) m (ev :: nil) srv m') From c67a7acc2abbe7f43cbd8eb0db4fbec96c620a7f Mon Sep 17 00:00:00 2001 From: ldj Date: Sat, 29 Apr 2023 14:40:11 +0200 Subject: [PATCH 032/174] WIP --- security/Backtranslation.v | 70 +++++++++++++++++++++++++++++++++++++- 1 file changed, 69 insertions(+), 1 deletion(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 816ce4d7a9..7894510c2d 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -27,7 +27,7 @@ Section GENV. (* ::: mkpass Unusedglobproof.match_prog *) (* match_prog_unique: *) (* list_norepet (prog_defs_names tp) *) - Lemma genv_def_to_ident + Lemma genv_def_to_some_ident (p: AST.program F V) (NR: list_norepet (prog_defs_names p)) ge @@ -43,6 +43,74 @@ Section GENV. 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. From 03826f64359b965cfa2362709da6e58dbd7099bc Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 2 May 2023 17:55:17 +0200 Subject: [PATCH 033/174] WIP: bt informative asm --- security/Backtranslation.v | 27 ------ security/BtInfoAsm.v | 184 +++++++++++++++++++++++++++++++++++++ 2 files changed, 184 insertions(+), 27 deletions(-) create mode 100644 security/BtInfoAsm.v diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 7894510c2d..fce1dbef6d 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -114,33 +114,6 @@ Section GENV. End GENV. -Section INFORMATIVE. - - (* At CROSS-COMP calls, if fundef is ext, set to is_ext. Otherwise is_not_ext. *) - (* Similar at return. *) - (* When a Event_syscall is is_cross_ext, do not back-translate Event_syscall and the following Event_return. *) - Variant cross_ext := | is_cross_ext | is_not_cross_ext. - - (* TODO: how to make code from block?? *) - (* To get information for inter-comp external calls or builtins *) - Variant sys_kind := - | sys_external (b: block) - | sys_builtin (ef: external_function) - (* | sys_inline (txt: string) (sg: signature) (strs: list string) *) - . - - Definition informative_event := (event * (cross_ext * (option sys_kind)))%type. - Definition informative_trace := list informative_event. - -End INFORMATIVE. - - -Section INFOASM. - - -End INFOASM. - - Section EXTFUN. diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v new file mode 100644 index 0000000000..ceb81a362a --- /dev/null +++ b/security/BtInfoAsm.v @@ -0,0 +1,184 @@ +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. + +Section INFORMATIVE. + + (* At CROSS-COMP calls, if fundef is ext, set to is_cross_ext. Otherwise is_not_ext. *) + (* Similar at return. *) + (* When a Event_call is is_cross_ext, do not back-translate the following Event_syscall and Event_return. *) + Variant cross_ext := | is_cross_ext | not_cross_ext. + + (* Additional information *) + Variant info_kind := + (* Get information for cross-comp calls and returns *) + | info_call (ce: cross_ext) (sg: signature) + | info_return (sg: signature) + (* Get information for inter-comp external calls or builtins *) + | info_external (b: block) (sg: signature) + | info_builtin (ef: external_function) + (* | info_default *) + . + + (* Informative events *) + Definition ievent := (event * info_kind)%type. + Definition itrace := list ievent. + + (* Informative to original *) + Definition iev_to_ev (ie: ievent) : event := (fst ie). + Definition itr_to_tr (ies: itrace) : trace := map iev_to_ev ies. + + (* Informative behavior *) + CoInductive itraceinf : Type := iEconsinf : ievent -> itraceinf -> itraceinf. + + Inductive iprogram_behavior : Type := + iTerminates : itrace -> int -> iprogram_behavior + | iDiverges : itrace -> iprogram_behavior + | iReacts : itraceinf -> iprogram_behavior + | iGoes_wrong : itrace -> iprogram_behavior. + +End INFORMATIVE. + + +Section INFOASM. + + Variable cpm: compartment. + Variable ge: genv. + + (* Parameter low_half: genv -> ident -> ptrofs -> ptrofs. *) + (* Parameter high_half: genv -> ident -> ptrofs -> val. *) + + (* Axiom low_high_half: *) + (* forall id ofs, *) + (* Val.offset_ptr (high_half ge id ofs) (low_half ge id ofs) = Genv.symbol_address ge id ofs. *) + + Inductive istep: state -> itrace -> state -> Prop := + | exec_istep_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 ge 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')), + istep (State st rs m) nil (State st rs' m') + | exec_istep_internal_call: + forall b ofs f i sig rs m rs' m' b' ofs' cp st st' args t it, + 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 ge 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' ofs')), + 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 ge 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), + forall (INFO: let ce := match (Genv.find_funct_ptr ge b', Genv.type_of_call ge (comp_of f) (Genv.find_comp_ignore_offset ge (Vptr b' ofs'))) with + | (Some (External ef), Genv.CrossCompartmentCall) => is_cross_ext + | _ => not_cross_ext + end in + it = map (fun e => (e, info_call ce sig)) t), + istep (State st rs m) it (State st' rs' m') + | exec_istep_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 ge 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 cpm st), + (* forall (NEXTCOMP: Genv.find_comp_ignore_offset ge (rs' PC) = cp'), *) + istep (State st rs m) nil (ReturnState st rs' m') + | exec_istep_return: + forall st st' rs m sg t rec_cp rec_cp' cp' it, + rs PC <> Vnullptr -> (* this condition is there to stop the execution 1 istep earlier, to make the proof easier *) + forall (REC_CURCOMP: callee_comp cpm st = rec_cp), + forall (REC_NEXTCOMP: call_comp ge 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 ge 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), + forall (INFO: it = map (fun e => (e, info_return sg)) t), + istep (ReturnState st rs m) it (State st' rs m) + | exec_istep_builtin: + forall b ofs f ef args res rs m vargs t vres rs' m' st it, + 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 res) -> + eval_builtin_args ge rs (rs SP) m args vargs -> + external_call ef ge (comp_of f) vargs m t vres m' -> + rs' = nextinstr + (set_res res vres + (undef_regs (map preg_of (destroyed_by_builtin ef)) + (rs #X1 <- Vundef #X31 <- Vundef))) -> + forall (INFO: it = map (fun e => (e, info_builtin ef)) t), + istep (State st rs m) it (State st rs' m') + | exec_istep_external: + forall b ef args res rs m t rs' m' cp st it, + 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 cp 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_istep_internal_return] case. *) + forall (REC_CURCOMP: Genv.find_comp_ignore_offset ge (rs PC) = callee_comp cpm st), + forall (INFO: it = map (fun e => (e, info_external b (ef_sig ef))) t), + istep (State st rs m) it (ReturnState st rs' m'). + + Inductive star (genv state : Type) (step : genv -> state -> trace -> state -> Prop) (ge : genv) : state -> trace -> state -> Prop := + star_refl : forall s : state, star step ge s E0 s + | star_step : forall (s1 : state) (t1 : trace) (s2 : state) (t2 : trace) (s3 : state) (t : trace), step ge s1 t1 s2 -> star step ge s2 t2 s3 -> t = t1 ** t2 -> star step ge s1 t s3. + + + Inductive istate_behaves (L : Smallstep.semantics) (s : Smallstep.state L) : iprogram_behavior -> Prop := + istate_terminates : forall (t : itrace) (s' : Smallstep.state L) (r : int), (star istep (globalenv L)) s t s' -> Smallstep.final_state L s' r -> istate_behaves L s (iTerminates t r). + | istate_diverges : forall (t : trace) (s' : Smallstep.state L), Star L s t s' -> Forever_silent L s' -> state_behaves L s (Diverges t) + | istate_reacts : forall T : traceinf, Forever_reactive L s T -> state_behaves L s (Reacts T) + | istate_goes_wrong : forall (t : trace) (s' : Smallstep.state L), Star L s t s' -> Nostep L s' -> (forall r : int, ~ Smallstep.final_state L s' r) -> state_behaves L s (Goes_wrong t). + + +asm_program_has_initial_trace = fun (p : program) (t : trace) => forall beh : program_behavior, program_behaves (semantics p) beh -> behavior_prefix t beh + : program -> trace -> Prop +Inductive program_behaves (L : Smallstep.semantics) : program_behavior -> Prop := + program_runs : forall (s : Smallstep.state L) (beh : program_behavior), Smallstep.initial_state L s -> state_behaves L s beh -> program_behaves L beh + | program_goes_initially_wrong : (forall s : Smallstep.state L, ~ Smallstep.initial_state L s) -> program_behaves L (Goes_wrong E0). +Inductive state_behaves (L : Smallstep.semantics) (s : Smallstep.state L) : program_behavior -> Prop := + state_terminates : forall (t : trace) (s' : Smallstep.state L) (r : int), Star L s t s' -> Smallstep.final_state L s' r -> state_behaves L s (Terminates t r) + | state_diverges : forall (t : trace) (s' : Smallstep.state L), Star L s t s' -> Forever_silent L s' -> state_behaves L s (Diverges t) + | state_reacts : forall T : traceinf, Forever_reactive L s T -> state_behaves L s (Reacts T) + | state_goes_wrong : forall (t : trace) (s' : Smallstep.state L), Star L s t s' -> Nostep L s' -> (forall r : int, ~ Smallstep.final_state L s' r) -> state_behaves L s (Goes_wrong t). +End INFOASM. + From 33e2a02bb7d8566e2fa2de380435e51ae4243f29 Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 3 May 2023 12:04:57 +0200 Subject: [PATCH 034/174] WIP --- security/BtInfoAsm.v | 87 +++++++++++++++++++++++++++++++++++++++----- 1 file changed, 78 insertions(+), 9 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index ceb81a362a..8630d61ff2 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -10,6 +10,8 @@ Require Import Complements. Section INFORMATIVE. + Import Smallstep. + (* At CROSS-COMP calls, if fundef is ext, set to is_cross_ext. Otherwise is_not_ext. *) (* Similar at return. *) (* When a Event_call is is_cross_ext, do not back-translate the following Event_syscall and Event_return. *) @@ -36,6 +38,14 @@ Section INFORMATIVE. (* Informative behavior *) CoInductive itraceinf : Type := iEconsinf : ievent -> itraceinf -> itraceinf. + CoFixpoint itri_to_tri (itri: itraceinf): traceinf := + match itri with iEconsinf hd tl => Econsinf (iev_to_ev hd) (itri_to_tri tl) end. + + Definition itri_to_tri_obs (itri: itraceinf) := + match itri with iEconsinf hd tl => iEconsinf hd tl end. + + Lemma itri_to_tri_obs_eq: forall itri, itri_to_tri_obs itri = itri. + Proof. destruct itri; reflexivity. Qed. Inductive iprogram_behavior : Type := iTerminates : itrace -> int -> iprogram_behavior @@ -43,10 +53,61 @@ Section INFORMATIVE. | iReacts : itraceinf -> iprogram_behavior | iGoes_wrong : itrace -> iprogram_behavior. + Definition iph_to_pb (ipb: iprogram_behavior): program_behavior := + match ipb with + | iTerminates itr r => Terminates (itr_to_tr itr) r + | iDiverges itr => Diverges (itr_to_tr itr) + | iReacts itri => Reacts (itri_to_tri itri) + | iGoes_wrong itr => Goes_wrong (itr_to_tr itr) + end. + + Inductive istar {genv state : Type} (step : genv -> state -> itrace -> state -> Prop) (ge : genv) : state -> itrace -> state -> Prop := + istar_refl : forall s : state, istar step ge s nil s + | istar_step : forall (s1 : state) (t1 : itrace) (s2 : state) (t2 : itrace) (s3 : state) (t : itrace), + step ge s1 t1 s2 -> istar step ge s2 t2 s3 -> t = t1 ++ t2 -> istar step ge s1 t s3. + + + Record isemantics : Type := + iSemantics_gen + { istate : Type; + igenvtype : Type; + istep : igenvtype -> istate -> itrace -> istate -> Prop; + iinitial_state : istate -> Prop; + ifinal_state : istate -> int -> Prop; + iglobalenv : igenvtype; + isymbolenv : Senv.t + }. + + Definition sem_to_isem (L: Smallstep.semantics) (istep: (genvtype L) -> (state L) -> itrace -> (state L) -> Prop) : isemantics := + iSemantics_gen _ _ istep (initial_state L) (final_state L) (globalenv L) (symbolenv L). + + CoInductive forever_silent (genv state : Type) (step : genv -> state -> trace -> state -> Prop) (ge : genv) : state -> Prop := + forever_silent_intro : forall s1 s2 : state, step ge s1 E0 s2 -> forever_silent step ge s2 -> forever_silent step ge s1. + + Inductive istate_behaves (L : isemantics) (s : istate L) : iprogram_behavior -> Prop := + istate_terminates : forall (t : itrace) (s' : istate L) (r : int), + (istar (istep L) (iglobalenv L)) s t s' -> ifinal_state L s' r -> istate_behaves L s (iTerminates t r) + | istate_diverges : forall (t : itrace) (s' : istate L), + (istar (istep L) (iglobalenv L)) s t s' -> (forever_silent (istep L) (iglobalenv L)) s' -> istate_behaves L s (iDiverges t). + | istate_reacts : forall T : itraceinf, forever_reactive L s T -> state_behaves L s (Reacts T) + | istate_goes_wrong : forall (t : trace) (s' : Smallstep.state L), Star L s t s' -> Nostep L s' -> (forall r : int, ~ Smallstep.final_state L s' r) -> state_behaves L s (Goes_wrong t). + + +asm_program_has_initial_trace = fun (p : program) (t : trace) => forall beh : program_behavior, program_behaves (semantics p) beh -> behavior_prefix t beh + : program -> trace -> Prop +Inductive program_behaves (L : Smallstep.semantics) : program_behavior -> Prop := + program_runs : forall (s : Smallstep.state L) (beh : program_behavior), Smallstep.initial_state L s -> state_behaves L s beh -> program_behaves L beh + | program_goes_initially_wrong : (forall s : Smallstep.state L, ~ Smallstep.initial_state L s) -> program_behaves L (Goes_wrong E0). +Inductive state_behaves (L : Smallstep.semantics) (s : Smallstep.state L) : program_behavior -> Prop := + state_terminates : forall (t : trace) (s' : Smallstep.state L) (r : int), Star L s t s' -> Smallstep.final_state L s' r -> state_behaves L s (Terminates t r) + | state_diverges : forall (t : trace) (s' : Smallstep.state L), Star L s t s' -> Forever_silent L s' -> state_behaves L s (Diverges t) + | state_reacts : forall T : traceinf, Forever_reactive L s T -> state_behaves L s (Reacts T) +| state_goes_wrong : forall (t : trace) (s' : Smallstep.state L), Star L s t s' -> Nostep L s' -> (forall r : int, ~ Smallstep.final_state L s' r) -> state_behaves L s (Goes_wrong t). + End INFORMATIVE. -Section INFOASM. +Section ASMISTEP. Variable cpm: compartment. Variable ge: genv. @@ -158,15 +219,23 @@ Section INFOASM. forall (INFO: it = map (fun e => (e, info_external b (ef_sig ef))) t), istep (State st rs m) it (ReturnState st rs' m'). - Inductive star (genv state : Type) (step : genv -> state -> trace -> state -> Prop) (ge : genv) : state -> trace -> state -> Prop := - star_refl : forall s : state, star step ge s E0 s - | star_step : forall (s1 : state) (t1 : trace) (s2 : state) (t2 : trace) (s3 : state) (t : trace), step ge s1 t1 s2 -> star step ge s2 t2 s3 -> t = t1 ** t2 -> star step ge s1 t s3. + Inductive istar {genv state : Type} (step : genv -> state -> itrace -> state -> Prop) (ge : genv) : state -> itrace -> state -> Prop := + istar_refl : forall s : state, istar step ge s nil s + | istar_step : forall (s1 : state) (t1 : itrace) (s2 : state) (t2 : itrace) (s3 : state) (t : itrace), + step ge s1 t1 s2 -> istar step ge s2 t2 s3 -> t = t1 ++ t2 -> istar step ge s1 t s3. + +End ASMISTEP. +Section INFOASM. + + Variable cpm: compartment. + Inductive istate_behaves (L : Smallstep.semantics) (s : Smallstep.state L) : iprogram_behavior -> Prop := - istate_terminates : forall (t : itrace) (s' : Smallstep.state L) (r : int), (star istep (globalenv L)) s t s' -> Smallstep.final_state L s' r -> istate_behaves L s (iTerminates t r). - | istate_diverges : forall (t : trace) (s' : Smallstep.state L), Star L s t s' -> Forever_silent L s' -> state_behaves L s (Diverges t) - | istate_reacts : forall T : traceinf, Forever_reactive L s T -> state_behaves L s (Reacts T) + istate_terminates : forall (t : itrace) (s' : Smallstep.state L) (r : int), + (istar (istep cpm) (globalenv L)) s t s' -> Smallstep.final_state L s' r -> istate_behaves L s (iTerminates t r). + | istate_diverges : forall (t : itrace) (s' : Smallstep.state L), (istar istep (globalenv L)) s t s' -> (forever_silent istep (globalenv L)) s' -> istate_behaves L s (iDiverges t) + | istate_reacts : forall T : itraceinf, forever_reactive L s T -> state_behaves L s (Reacts T) | istate_goes_wrong : forall (t : trace) (s' : Smallstep.state L), Star L s t s' -> Nostep L s' -> (forall r : int, ~ Smallstep.final_state L s' r) -> state_behaves L s (Goes_wrong t). @@ -179,6 +248,6 @@ Inductive state_behaves (L : Smallstep.semantics) (s : Smallstep.state L) : prog state_terminates : forall (t : trace) (s' : Smallstep.state L) (r : int), Star L s t s' -> Smallstep.final_state L s' r -> state_behaves L s (Terminates t r) | state_diverges : forall (t : trace) (s' : Smallstep.state L), Star L s t s' -> Forever_silent L s' -> state_behaves L s (Diverges t) | state_reacts : forall T : traceinf, Forever_reactive L s T -> state_behaves L s (Reacts T) - | state_goes_wrong : forall (t : trace) (s' : Smallstep.state L), Star L s t s' -> Nostep L s' -> (forall r : int, ~ Smallstep.final_state L s' r) -> state_behaves L s (Goes_wrong t). -End INFOASM. +| state_goes_wrong : forall (t : trace) (s' : Smallstep.state L), Star L s t s' -> Nostep L s' -> (forall r : int, ~ Smallstep.final_state L s' r) -> state_behaves L s (Goes_wrong t). +End INFOASM. From f95a9f2f74ba541b055aed317c2c809961883ed5 Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 3 May 2023 18:06:38 +0200 Subject: [PATCH 035/174] WIP --- security/BtInfoAsm.v | 335 ++++++++++++++++++++++++++++++------------- 1 file changed, 233 insertions(+), 102 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 8630d61ff2..d3da1bb874 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -8,8 +8,74 @@ Require Import riscV.Machregs. Require Import riscV.Asm. Require Import Complements. -Section INFORMATIVE. +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. + + (* semantics_determinate: forall p : program, determinate (Asm.semantics p) *) + (* sd_traces: forall [L : semantics], determinate L -> single_events L *) + + Lemma state_behaves_app_inv + L s1 beh t beh' + (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. + inv BEH. + - destruct beh'; simpl in *; try congruence. inv H1. + remember (t ** t1) as tr. revert t t1 i ONE Heqtr H0. induction H; intros. + { symmetry in Heqtr; apply Eapp_E0_inv in Heqtr. destruct Heqtr; subst. exists s. split. + constructor 1. econstructor 1; eauto. constructor 1. + } + subst. + admit. + - destruct beh'; simpl in *; try congruence. inv H1. + admit. + - destruct beh'; simpl in *; try congruence. inv H0. + admit. + - destruct beh'; simpl in *; try congruence. inv H2. + admit. + - + + Lemma semantics_has_initial_trace_prefix_implies_cut + L t + (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. + +End HASINIT. + +Section INFORMATIVE. Import Smallstep. (* At CROSS-COMP calls, if fundef is ext, set to is_cross_ext. Otherwise is_not_ext. *) @@ -32,34 +98,43 @@ Section INFORMATIVE. Definition ievent := (event * info_kind)%type. Definition itrace := list ievent. + Definition iE0: itrace := nil. + (* Informative to original *) Definition iev_to_ev (ie: ievent) : event := (fst ie). Definition itr_to_tr (ies: itrace) : trace := map iev_to_ev ies. (* Informative behavior *) - CoInductive itraceinf : Type := iEconsinf : ievent -> itraceinf -> itraceinf. - CoFixpoint itri_to_tri (itri: itraceinf): traceinf := - match itri with iEconsinf hd tl => Econsinf (iev_to_ev hd) (itri_to_tri tl) end. - - Definition itri_to_tri_obs (itri: itraceinf) := - match itri with iEconsinf hd tl => iEconsinf hd tl end. - - Lemma itri_to_tri_obs_eq: forall itri, itri_to_tri_obs itri = itri. - Proof. destruct itri; reflexivity. Qed. - - Inductive iprogram_behavior : Type := - iTerminates : itrace -> int -> iprogram_behavior - | iDiverges : itrace -> iprogram_behavior - | iReacts : itraceinf -> iprogram_behavior - | iGoes_wrong : itrace -> iprogram_behavior. - - Definition iph_to_pb (ipb: iprogram_behavior): program_behavior := - match ipb with - | iTerminates itr r => Terminates (itr_to_tr itr) r - | iDiverges itr => Diverges (itr_to_tr itr) - | iReacts itri => Reacts (itri_to_tri itri) - | iGoes_wrong itr => Goes_wrong (itr_to_tr itr) - end. + (* CoInductive itraceinf : Type := iEconsinf : ievent -> itraceinf -> itraceinf. *) + (* CoFixpoint itri_to_tri (itri: itraceinf): traceinf := *) + (* match itri with iEconsinf hd tl => Econsinf (iev_to_ev hd) (itri_to_tri tl) end. *) + + (* Definition itri_to_tri_obs (itri: itraceinf) := *) + (* match itri with iEconsinf hd tl => iEconsinf hd tl end. *) + + (* Lemma itri_to_tri_obs_eq: forall itri, itri_to_tri_obs itri = itri. *) + (* Proof. destruct itri; reflexivity. Qed. *) + + (* Fixpoint iEappinf (t: itrace) (T: itraceinf) {struct t} : itraceinf := *) + (* match t with *) + (* | nil => T *) + (* | ev :: t' => iEconsinf ev (iEappinf t' T) *) + (* end. *) + + + (* Inductive iprogram_behavior : Type := *) + (* iTerminates : itrace -> int -> iprogram_behavior *) + (* | iDiverges : itrace -> iprogram_behavior *) + (* | iReacts : itraceinf -> iprogram_behavior *) + (* | iGoes_wrong : itrace -> iprogram_behavior. *) + + (* Definition iph_to_pb (ipb: iprogram_behavior): program_behavior := *) + (* match ipb with *) + (* | iTerminates itr r => Terminates (itr_to_tr itr) r *) + (* | iDiverges itr => Diverges (itr_to_tr itr) *) + (* | iReacts itri => Reacts (itri_to_tri itri) *) + (* | iGoes_wrong itr => Goes_wrong (itr_to_tr itr) *) + (* end. *) Inductive istar {genv state : Type} (step : genv -> state -> itrace -> state -> Prop) (ge : genv) : state -> itrace -> state -> Prop := istar_refl : forall s : state, istar step ge s nil s @@ -67,46 +142,121 @@ Section INFORMATIVE. step ge s1 t1 s2 -> istar step ge s2 t2 s3 -> t = t1 ++ t2 -> istar step ge s1 t s3. - Record isemantics : Type := - iSemantics_gen - { istate : Type; - igenvtype : Type; - istep : igenvtype -> istate -> itrace -> istate -> Prop; - iinitial_state : istate -> Prop; - ifinal_state : istate -> int -> Prop; - iglobalenv : igenvtype; - isymbolenv : Senv.t - }. - - Definition sem_to_isem (L: Smallstep.semantics) (istep: (genvtype L) -> (state L) -> itrace -> (state L) -> Prop) : isemantics := - iSemantics_gen _ _ istep (initial_state L) (final_state L) (globalenv L) (symbolenv L). - - CoInductive forever_silent (genv state : Type) (step : genv -> state -> trace -> state -> Prop) (ge : genv) : state -> Prop := - forever_silent_intro : forall s1 s2 : state, step ge s1 E0 s2 -> forever_silent step ge s2 -> forever_silent step ge s1. - - Inductive istate_behaves (L : isemantics) (s : istate L) : iprogram_behavior -> Prop := - istate_terminates : forall (t : itrace) (s' : istate L) (r : int), - (istar (istep L) (iglobalenv L)) s t s' -> ifinal_state L s' r -> istate_behaves L s (iTerminates t r) - | istate_diverges : forall (t : itrace) (s' : istate L), - (istar (istep L) (iglobalenv L)) s t s' -> (forever_silent (istep L) (iglobalenv L)) s' -> istate_behaves L s (iDiverges t). - | istate_reacts : forall T : itraceinf, forever_reactive L s T -> state_behaves L s (Reacts T) - | istate_goes_wrong : forall (t : trace) (s' : Smallstep.state L), Star L s t s' -> Nostep L s' -> (forall r : int, ~ Smallstep.final_state L s' r) -> state_behaves L s (Goes_wrong t). - - -asm_program_has_initial_trace = fun (p : program) (t : trace) => forall beh : program_behavior, program_behaves (semantics p) beh -> behavior_prefix t beh - : program -> trace -> Prop -Inductive program_behaves (L : Smallstep.semantics) : program_behavior -> Prop := - program_runs : forall (s : Smallstep.state L) (beh : program_behavior), Smallstep.initial_state L s -> state_behaves L s beh -> program_behaves L beh - | program_goes_initially_wrong : (forall s : Smallstep.state L, ~ Smallstep.initial_state L s) -> program_behaves L (Goes_wrong E0). -Inductive state_behaves (L : Smallstep.semantics) (s : Smallstep.state L) : program_behavior -> Prop := - state_terminates : forall (t : trace) (s' : Smallstep.state L) (r : int), Star L s t s' -> Smallstep.final_state L s' r -> state_behaves L s (Terminates t r) - | state_diverges : forall (t : trace) (s' : Smallstep.state L), Star L s t s' -> Forever_silent L s' -> state_behaves L s (Diverges t) - | state_reacts : forall T : traceinf, Forever_reactive L s T -> state_behaves L s (Reacts T) -| state_goes_wrong : forall (t : trace) (s' : Smallstep.state L), Star L s t s' -> Nostep L s' -> (forall r : int, ~ Smallstep.final_state L s' r) -> state_behaves L s (Goes_wrong t). + (* Record isemantics : Type := *) + (* iSemantics_gen *) + (* { istate : Type; *) + (* igenvtype : Type; *) + (* istep : igenvtype -> istate -> itrace -> istate -> Prop; *) + (* iinitial_state : istate -> Prop; *) + (* ifinal_state : istate -> int -> Prop; *) + (* iglobalenv : igenvtype; *) + (* isymbolenv : Senv.t *) + (* }. *) + + (* Definition sem_to_isem (L: Smallstep.semantics) (istep: (genvtype L) -> (state L) -> itrace -> (state L) -> Prop) : isemantics := *) + (* iSemantics_gen _ _ istep (initial_state L) (final_state L) (globalenv L) (symbolenv L). *) + + CoInductive iforever_silent (genv state : Type) (step : genv -> state -> itrace -> state -> Prop) (ge : genv) : state -> Prop := + iforever_silent_intro : forall s1 s2 : state, step ge s1 nil s2 -> iforever_silent _ _ step ge s2 -> iforever_silent _ _ step ge s1. + + CoInductive iforever_reactive (genv state : Type) (step : genv -> state -> itrace -> state -> Prop) (ge : genv) : state -> itraceinf -> Prop := + iforever_reactive_intro : forall (s1 s2 : state) (t : itrace) (T : itraceinf), + istar step ge s1 t s2 -> t <> nil -> iforever_reactive _ _ step ge s2 T -> iforever_reactive _ _ step ge s1 (iEappinf t T). + + Definition inostep := fun (genv state : Type) (step : genv -> state -> itrace -> state -> Prop) (ge : genv) (s : state) => forall (t : itrace) (s' : state), ~ step ge s t s'. + + Inductive istate_behaves (L : semantics) (istep: (genvtype L) -> (state L) -> itrace -> (state L) -> Prop) (s : state L): itrace -> program_behavior -> Prop := + istate_terminates : forall (t : itrace) (s' : state L) (r : int), + (istar istep (globalenv L)) s t s' -> final_state L s' r -> istate_behaves L istep s t (Terminates (itr_to_tr t) r) + | istate_diverges : forall (t : itrace) (s' : state L), + (istar (istep) (globalenv L)) s t s' -> (forever_silent _ _ (step L) (globalenv L)) s' -> istate_behaves L istep s t (Diverges (itr_to_tr t)) + | istate_reacts : forall (t: itrace) (T : traceinf), + (iforever_reactive _ _ (istep L) (iglobalenv L)) s T -> istate_behaves L istep s t (Reacts T) + | istate_goes_wrong : forall (t : itrace) (s' : istate L), + (istar (istep L) (iglobalenv L)) s t s' -> (inostep _ _ (istep L) (iglobalenv L)) s' -> (forall r : int, ~ ifinal_state L s' r) -> istate_behaves L s (iGoes_wrong t). + + Inductive iprogram_behaves (L : semantics) (istep: (genvtype L) -> (state L) -> itrace -> (state L) -> Prop): itrace -> program_behavior -> Prop := + iprogram_runs : forall (s : state L) (t: itrace) (beh : iprogram_behavior), + initial_state L s -> istate_behaves L istep s t beh -> iprogram_behaves L t beh + | iprogram_goes_initially_wrong : (forall s : state L, ~ initial_state L s) -> iprogram_behaves L nil (Goes_wrong nil). + + Definition semantics_has_initial_trace_informative (L: semantics) (istep: (genvtype L) -> (state L) -> itrace -> (state L) -> Prop) (t: itrace): Prop := + exists beh, (iprogram_behaves L istep t beh). End INFORMATIVE. +Lemma iE0_left: forall t, iE0 ++ t = t. +Proof. auto. Qed. + +Lemma iE0_right: forall t, t ++ iE0 = t. +Proof. intros. unfold iE0, Eapp. rewrite <- app_nil_end. auto. Qed. + +Lemma iEapp_assoc: forall (t1 t2 t3: itrace), (t1 ++ t2) ++ t3 = t1 ++ (t2 ++ t3). +Proof. intros. unfold Eapp, trace. apply app_ass. Qed. + +Lemma iEapp_E0_inv: forall t1 t2, t1 ++ t2 = iE0 -> t1 = iE0 /\ t2 = iE0. +Proof. eapply (@app_eq_nil ievent). Qed. + +Lemma iE0_left_inf: forall T, iEappinf iE0 T = T. +Proof. auto. Qed. + +Lemma iEappinf_assoc: forall t1 t2 T, iEappinf (t1 ++ t2) T = iEappinf t1 (iEappinf t2 T). +Proof. + induction t1; intros; simpl. auto. decEq; auto. +Qed. + +#[global] +Hint Rewrite iE0_left iE0_right iEapp_assoc + iE0_left_inf iEappinf_assoc: itrace_rewrite. + +Ltac isubstTraceHyp := + match goal with + | [ H: (@eq itrace ?x ?y) |- _ ] => + subst x || clear H + end. + +Ltac idecomposeTraceEq := + match goal with + | [ |- (_ ++ _) = (_ ++ _) ] => + apply (f_equal2 app); auto; decomposeTraceEq + | _ => + auto + end. + +Ltac itraceEq := + repeat isubstTraceHyp; autorewrite with itrace_rewrite; idecomposeTraceEq. + + +Section AUX. + + Definition ibehavior_app (t: itrace) (beh: iprogram_behavior): iprogram_behavior := + match beh with + | iTerminates t1 r => iTerminates (t ++ t1) r + | iDiverges t1 => iDiverges (t ++ t1) + | iReacts T => iReacts (iEappinf t T) + | iGoes_wrong t1 => iGoes_wrong (t ++ t1) + end. + + Lemma ibehavior_app_assoc: + forall t1 t2 beh, + ibehavior_app (t1 ++ t2) beh = ibehavior_app t1 (ibehavior_app t2 beh). + Proof. + intros. destruct beh; simpl; f_equal; itraceEq. + Qed. + + Lemma ibehavior_app_E0: + forall beh, ibehavior_app iE0 beh = beh. + Proof. + destruct beh; auto. + Qed. + + Definition ibehavior_prefix (t: itrace) (beh: iprogram_behavior) : Prop := + exists beh', beh = ibehavior_app t beh'. + +End AUX. + + Section ASMISTEP. Variable cpm: compartment. @@ -119,8 +269,8 @@ Section ASMISTEP. (* forall id ofs, *) (* Val.offset_ptr (high_half ge id ofs) (low_half ge id ofs) = Genv.symbol_address ge id ofs. *) - Inductive istep: state -> itrace -> state -> Prop := - | exec_istep_internal: + Inductive asm_istep: state -> itrace -> state -> Prop := + | exec_asm_istep_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) -> @@ -131,8 +281,8 @@ Section ASMISTEP. is_return i = false -> forall (NEXTPC: rs' PC = Vptr b' ofs'), forall (ALLOWED: cp = Genv.find_comp_ignore_offset ge (Vptr b' ofs')), - istep (State st rs m) nil (State st rs' m') - | exec_istep_internal_call: + asm_istep (State st rs m) nil (State st rs' m') + | exec_asm_istep_internal_call: forall b ofs f i sig rs m rs' m' b' ofs' cp st st' args t it, rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> @@ -156,8 +306,8 @@ Section ASMISTEP. | _ => not_cross_ext end in it = map (fun e => (e, info_call ce sig)) t), - istep (State st rs m) it (State st' rs' m') - | exec_istep_internal_return: + asm_istep (State st rs m) it (State st' rs' m') + | exec_asm_istep_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) -> @@ -170,10 +320,10 @@ Section ASMISTEP. (* of the top stack frame*) forall (REC_CURCOMP: Genv.find_comp_ignore_offset ge (rs PC) = callee_comp cpm st), (* forall (NEXTCOMP: Genv.find_comp_ignore_offset ge (rs' PC) = cp'), *) - istep (State st rs m) nil (ReturnState st rs' m') - | exec_istep_return: + asm_istep (State st rs m) nil (ReturnState st rs' m') + | exec_asm_istep_return: forall st st' rs m sg t rec_cp rec_cp' cp' it, - rs PC <> Vnullptr -> (* this condition is there to stop the execution 1 istep earlier, to make the proof easier *) + rs PC <> Vnullptr -> (* this condition is there to stop the execution 1 asm_istep earlier, to make the proof easier *) forall (REC_CURCOMP: callee_comp cpm st = rec_cp), forall (REC_NEXTCOMP: call_comp ge st = rec_cp'), forall (NEXTCOMP: Genv.find_comp_ignore_offset ge (rs PC) = cp'), @@ -192,8 +342,8 @@ Section ASMISTEP. not_ptr (return_value rs sg))), forall (EV: return_trace ge cp' rec_cp (return_value rs sg) (sig_res sg) t), forall (INFO: it = map (fun e => (e, info_return sg)) t), - istep (ReturnState st rs m) it (State st' rs m) - | exec_istep_builtin: + asm_istep (ReturnState st rs m) it (State st' rs m) + | exec_asm_istep_builtin: forall b ofs f ef args res rs m vargs t vres rs' m' st it, rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> @@ -205,8 +355,8 @@ Section ASMISTEP. (undef_regs (map preg_of (destroyed_by_builtin ef)) (rs #X1 <- Vundef #X31 <- Vundef))) -> forall (INFO: it = map (fun e => (e, info_builtin ef)) t), - istep (State st rs m) it (State st rs' m') - | exec_istep_external: + asm_istep (State st rs m) it (State st rs' m') + | exec_asm_istep_external: forall b ef args res rs m t rs' m' cp st it, rs PC = Vptr b Ptrofs.zero -> Genv.find_funct_ptr ge b = Some (External ef) -> @@ -214,40 +364,21 @@ Section ASMISTEP. external_call ef ge cp 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_istep_internal_return] case. *) + (* These steps behave like returns. So we do the same as in the [exec_asm_istep_internal_return] case. *) forall (REC_CURCOMP: Genv.find_comp_ignore_offset ge (rs PC) = callee_comp cpm st), forall (INFO: it = map (fun e => (e, info_external b (ef_sig ef))) t), - istep (State st rs m) it (ReturnState st rs' m'). - - Inductive istar {genv state : Type} (step : genv -> state -> itrace -> state -> Prop) (ge : genv) : state -> itrace -> state -> Prop := - istar_refl : forall s : state, istar step ge s nil s - | istar_step : forall (s1 : state) (t1 : itrace) (s2 : state) (t2 : itrace) (s3 : state) (t : itrace), - step ge s1 t1 s2 -> istar step ge s2 t2 s3 -> t = t1 ++ t2 -> istar step ge s1 t s3. + asm_istep (State st rs m) it (ReturnState st rs' m'). End ASMISTEP. -Section INFOASM. +Section ASMISEM. - Variable cpm: compartment. + Definition iasm_program_has_initial_trace := + fun (p : program) (t : itrace) => + let isem := sem_to_isem (semantics p) (asm_istep (prog_main p)) in + exists beh : iprogram_behavior, (iprogram_behaves isem beh) /\ (ibehavior_prefix t beh). + + - Inductive istate_behaves (L : Smallstep.semantics) (s : Smallstep.state L) : iprogram_behavior -> Prop := - istate_terminates : forall (t : itrace) (s' : Smallstep.state L) (r : int), - (istar (istep cpm) (globalenv L)) s t s' -> Smallstep.final_state L s' r -> istate_behaves L s (iTerminates t r). - | istate_diverges : forall (t : itrace) (s' : Smallstep.state L), (istar istep (globalenv L)) s t s' -> (forever_silent istep (globalenv L)) s' -> istate_behaves L s (iDiverges t) - | istate_reacts : forall T : itraceinf, forever_reactive L s T -> state_behaves L s (Reacts T) - | istate_goes_wrong : forall (t : trace) (s' : Smallstep.state L), Star L s t s' -> Nostep L s' -> (forall r : int, ~ Smallstep.final_state L s' r) -> state_behaves L s (Goes_wrong t). - - -asm_program_has_initial_trace = fun (p : program) (t : trace) => forall beh : program_behavior, program_behaves (semantics p) beh -> behavior_prefix t beh - : program -> trace -> Prop -Inductive program_behaves (L : Smallstep.semantics) : program_behavior -> Prop := - program_runs : forall (s : Smallstep.state L) (beh : program_behavior), Smallstep.initial_state L s -> state_behaves L s beh -> program_behaves L beh - | program_goes_initially_wrong : (forall s : Smallstep.state L, ~ Smallstep.initial_state L s) -> program_behaves L (Goes_wrong E0). -Inductive state_behaves (L : Smallstep.semantics) (s : Smallstep.state L) : program_behavior -> Prop := - state_terminates : forall (t : trace) (s' : Smallstep.state L) (r : int), Star L s t s' -> Smallstep.final_state L s' r -> state_behaves L s (Terminates t r) - | state_diverges : forall (t : trace) (s' : Smallstep.state L), Star L s t s' -> Forever_silent L s' -> state_behaves L s (Diverges t) - | state_reacts : forall T : traceinf, Forever_reactive L s T -> state_behaves L s (Reacts T) -| state_goes_wrong : forall (t : trace) (s' : Smallstep.state L), Star L s t s' -> Nostep L s' -> (forall r : int, ~ Smallstep.final_state L s' r) -> state_behaves L s (Goes_wrong t). - -End INFOASM. +End ASMISEM. From ffa5d06fa47f51bfcbf340423088a9cd6eb2d0aa Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 3 May 2023 20:52:33 +0200 Subject: [PATCH 036/174] WIP; proved prefix <-> cut --- security/BtInfoAsm.v | 83 ++++++++++++++++++++++++++++++++++++-------- 1 file changed, 68 insertions(+), 15 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index d3da1bb874..f47f976e88 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -37,40 +37,93 @@ Section HASINIT. (* semantics_determinate: forall p : program, determinate (Asm.semantics p) *) (* sd_traces: forall [L : semantics], determinate L -> single_events L *) - Lemma state_behaves_app_inv + 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) + (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 (t ** t1) as tr. revert t t1 i ONE Heqtr H0. induction H; intros. - { symmetry in Heqtr; apply Eapp_E0_inv in Heqtr. destruct Heqtr; subst. exists s. split. - constructor 1. econstructor 1; eauto. constructor 1. - } - subst. - admit. + 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. - admit. + 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. - admit. + 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. - admit. - - + 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. + - 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. From 2c07cd795903a90f546b54a084497518748a40ec Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 4 May 2023 15:04:18 +0200 Subject: [PATCH 037/174] WIP; proved asm -> info asm --- security/BtInfoAsm.v | 189 ++++++++++++++++++++++++++++++------------- 1 file changed, 131 insertions(+), 58 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index f47f976e88..85e486dd4c 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -209,32 +209,39 @@ Section INFORMATIVE. (* Definition sem_to_isem (L: Smallstep.semantics) (istep: (genvtype L) -> (state L) -> itrace -> (state L) -> Prop) : isemantics := *) (* iSemantics_gen _ _ istep (initial_state L) (final_state L) (globalenv L) (symbolenv L). *) - CoInductive iforever_silent (genv state : Type) (step : genv -> state -> itrace -> state -> Prop) (ge : genv) : state -> Prop := - iforever_silent_intro : forall s1 s2 : state, step ge s1 nil s2 -> iforever_silent _ _ step ge s2 -> iforever_silent _ _ step ge s1. + (* CoInductive iforever_silent (genv state : Type) (step : genv -> state -> itrace -> state -> Prop) (ge : genv) : state -> Prop := *) + (* iforever_silent_intro : forall s1 s2 : state, step ge s1 nil s2 -> iforever_silent _ _ step ge s2 -> iforever_silent _ _ step ge s1. *) - CoInductive iforever_reactive (genv state : Type) (step : genv -> state -> itrace -> state -> Prop) (ge : genv) : state -> itraceinf -> Prop := - iforever_reactive_intro : forall (s1 s2 : state) (t : itrace) (T : itraceinf), - istar step ge s1 t s2 -> t <> nil -> iforever_reactive _ _ step ge s2 T -> iforever_reactive _ _ step ge s1 (iEappinf t T). + (* CoInductive iforever_reactive (genv state : Type) (step : genv -> state -> itrace -> state -> Prop) (ge : genv) : state -> itraceinf -> Prop := *) + (* iforever_reactive_intro : forall (s1 s2 : state) (t : itrace) (T : itraceinf), *) + (* istar step ge s1 t s2 -> t <> nil -> iforever_reactive _ _ step ge s2 T -> iforever_reactive _ _ step ge s1 (iEappinf t T). *) - Definition inostep := fun (genv state : Type) (step : genv -> state -> itrace -> state -> Prop) (ge : genv) (s : state) => forall (t : itrace) (s' : state), ~ step ge s t s'. + (* Definition inostep := fun (genv state : Type) (step : genv -> state -> itrace -> state -> Prop) (ge : genv) (s : state) => forall (t : itrace) (s' : state), ~ step ge s t s'. *) - Inductive istate_behaves (L : semantics) (istep: (genvtype L) -> (state L) -> itrace -> (state L) -> Prop) (s : state L): itrace -> program_behavior -> Prop := - istate_terminates : forall (t : itrace) (s' : state L) (r : int), - (istar istep (globalenv L)) s t s' -> final_state L s' r -> istate_behaves L istep s t (Terminates (itr_to_tr t) r) - | istate_diverges : forall (t : itrace) (s' : state L), - (istar (istep) (globalenv L)) s t s' -> (forever_silent _ _ (step L) (globalenv L)) s' -> istate_behaves L istep s t (Diverges (itr_to_tr t)) - | istate_reacts : forall (t: itrace) (T : traceinf), - (iforever_reactive _ _ (istep L) (iglobalenv L)) s T -> istate_behaves L istep s t (Reacts T) - | istate_goes_wrong : forall (t : itrace) (s' : istate L), - (istar (istep L) (iglobalenv L)) s t s' -> (inostep _ _ (istep L) (iglobalenv L)) s' -> (forall r : int, ~ ifinal_state L s' r) -> istate_behaves L s (iGoes_wrong t). + (* Inductive istate_behaves (L : semantics) (istep: (genvtype L) -> (state L) -> itrace -> (state L) -> Prop) (s : state L): itrace -> program_behavior -> Prop := *) + (* istate_terminates : forall (t : itrace) (s' : state L) (r : int), *) + (* (istar istep (globalenv L)) s t s' -> final_state L s' r -> istate_behaves L istep s t (Terminates (itr_to_tr t) r) *) + (* | istate_diverges : forall (t : itrace) (s' : state L), *) + (* (istar (istep) (globalenv L)) s t s' -> (forever_silent _ _ (step L) (globalenv L)) s' -> istate_behaves L istep s t (Diverges (itr_to_tr t)) *) + (* | istate_reacts : forall (t: itrace) (T : traceinf), *) + (* (iforever_reactive _ _ (istep L) (iglobalenv L)) s T -> istate_behaves L istep s t (Reacts T) *) + (* | istate_goes_wrong : forall (t : itrace) (s' : istate L), *) + (* (istar (istep L) (iglobalenv L)) s t s' -> (inostep _ _ (istep L) (iglobalenv L)) s' -> (forall r : int, ~ ifinal_state L s' r) -> istate_behaves L s (iGoes_wrong t). *) - Inductive iprogram_behaves (L : semantics) (istep: (genvtype L) -> (state L) -> itrace -> (state L) -> Prop): itrace -> program_behavior -> Prop := - iprogram_runs : forall (s : state L) (t: itrace) (beh : iprogram_behavior), - initial_state L s -> istate_behaves L istep s t beh -> iprogram_behaves L t beh - | iprogram_goes_initially_wrong : (forall s : state L, ~ initial_state L s) -> iprogram_behaves L nil (Goes_wrong nil). + (* Inductive iprogram_behaves (L : semantics) (istep: (genvtype L) -> (state L) -> itrace -> (state L) -> Prop): itrace -> program_behavior -> Prop := *) + (* iprogram_runs : forall (s : state L) (t: itrace) (beh : iprogram_behavior), *) + (* initial_state L s -> istate_behaves L istep s t beh -> iprogram_behaves L t beh *) + (* | iprogram_goes_initially_wrong : (forall s : state L, ~ initial_state L s) -> iprogram_behaves L nil (Goes_wrong nil). *) - Definition semantics_has_initial_trace_informative (L: semantics) (istep: (genvtype L) -> (state L) -> itrace -> (state L) -> Prop) (t: itrace): Prop := - exists beh, (iprogram_behaves L istep t beh). + Definition istep (L: Smallstep.semantics) := (genvtype L) -> (state L) -> itrace -> (state L) -> Prop. + + Definition state_has_trace_informative (L: Smallstep.semantics) (s: state L) (step: istep L) (t: itrace): Prop := + (exists s', (istar step (globalenv L)) s t s'). + + Variant semantics_has_initial_trace_informative (L: Smallstep.semantics) (step: istep L) (t: itrace) : Prop := + | semantics_info_runs : + forall s, (initial_state L s) -> (state_has_trace_informative L s step t) -> semantics_has_initial_trace_informative _ _ t + | semantics_info_goes_initially_wrong : (forall s : state L, ~ initial_state L s) -> (t = nil) -> semantics_has_initial_trace_informative _ _ t. End INFORMATIVE. @@ -251,17 +258,18 @@ Proof. intros. unfold Eapp, trace. apply app_ass. Qed. Lemma iEapp_E0_inv: forall t1 t2, t1 ++ t2 = iE0 -> t1 = iE0 /\ t2 = iE0. Proof. eapply (@app_eq_nil ievent). Qed. -Lemma iE0_left_inf: forall T, iEappinf iE0 T = T. -Proof. auto. Qed. +(* Lemma iE0_left_inf: forall T, iEappinf iE0 T = T. *) +(* Proof. auto. Qed. *) -Lemma iEappinf_assoc: forall t1 t2 T, iEappinf (t1 ++ t2) T = iEappinf t1 (iEappinf t2 T). -Proof. - induction t1; intros; simpl. auto. decEq; auto. -Qed. +(* Lemma iEappinf_assoc: forall t1 t2 T, iEappinf (t1 ++ t2) T = iEappinf t1 (iEappinf t2 T). *) +(* Proof. *) +(* induction t1; intros; simpl. auto. decEq; auto. *) +(* Qed. *) #[global] -Hint Rewrite iE0_left iE0_right iEapp_assoc - iE0_left_inf iEappinf_assoc: itrace_rewrite. +Hint Rewrite iE0_left iE0_right iEapp_assoc: itrace_rewrite. +(* Hint Rewrite iE0_left iE0_right iEapp_assoc *) +(* iE0_left_inf iEappinf_assoc: itrace_rewrite. *) Ltac isubstTraceHyp := match goal with @@ -281,33 +289,33 @@ Ltac itraceEq := repeat isubstTraceHyp; autorewrite with itrace_rewrite; idecomposeTraceEq. -Section AUX. +(* Section AUX. *) - Definition ibehavior_app (t: itrace) (beh: iprogram_behavior): iprogram_behavior := - match beh with - | iTerminates t1 r => iTerminates (t ++ t1) r - | iDiverges t1 => iDiverges (t ++ t1) - | iReacts T => iReacts (iEappinf t T) - | iGoes_wrong t1 => iGoes_wrong (t ++ t1) - end. +(* Definition ibehavior_app (t: itrace) (beh: iprogram_behavior): iprogram_behavior := *) +(* match beh with *) +(* | iTerminates t1 r => iTerminates (t ++ t1) r *) +(* | iDiverges t1 => iDiverges (t ++ t1) *) +(* | iReacts T => iReacts (iEappinf t T) *) +(* | iGoes_wrong t1 => iGoes_wrong (t ++ t1) *) +(* end. *) - Lemma ibehavior_app_assoc: - forall t1 t2 beh, - ibehavior_app (t1 ++ t2) beh = ibehavior_app t1 (ibehavior_app t2 beh). - Proof. - intros. destruct beh; simpl; f_equal; itraceEq. - Qed. +(* Lemma ibehavior_app_assoc: *) +(* forall t1 t2 beh, *) +(* ibehavior_app (t1 ++ t2) beh = ibehavior_app t1 (ibehavior_app t2 beh). *) +(* Proof. *) +(* intros. destruct beh; simpl; f_equal; itraceEq. *) +(* Qed. *) - Lemma ibehavior_app_E0: - forall beh, ibehavior_app iE0 beh = beh. - Proof. - destruct beh; auto. - Qed. +(* Lemma ibehavior_app_E0: *) +(* forall beh, ibehavior_app iE0 beh = beh. *) +(* Proof. *) +(* destruct beh; auto. *) +(* Qed. *) - Definition ibehavior_prefix (t: itrace) (beh: iprogram_behavior) : Prop := - exists beh', beh = ibehavior_app t beh'. +(* Definition ibehavior_prefix (t: itrace) (beh: iprogram_behavior) : Prop := *) +(* exists beh', beh = ibehavior_app t beh'. *) -End AUX. +(* End AUX. *) Section ASMISTEP. @@ -425,13 +433,78 @@ Section ASMISTEP. End ASMISTEP. -Section ASMISEM. +Section ASMITR. + + Definition asm_has_initial_trace_informative (p: Asm.program) (t: itrace) := + semantics_has_initial_trace_informative (semantics p) (asm_istep (comp_of_main p)) t. - Definition iasm_program_has_initial_trace := - fun (p : program) (t : itrace) => - let isem := sem_to_isem (semantics p) (asm_istep (prog_main p)) in - exists beh : iprogram_behavior, (iprogram_behaves isem beh) /\ (ibehavior_prefix t beh). + Definition asm_has_initial_trace (p: Asm.program) (t: trace): Prop := semantics_has_initial_trace_prefix (Asm.semantics p) t. - -End ASMISEM. + Lemma asm_star_tr_implies_istar_info_tr + (p: Asm.program) (t: trace) + (s s': Asm.state) + (STAR: Star (semantics p) s t s') + : + exists it, (state_has_trace_informative (semantics p) s (asm_istep (comp_of_main p)) it) /\ (itr_to_tr it = t). + Proof. + simpl in STAR. induction STAR. + { exists nil. simpl; split; auto. exists s. econstructor 1. } + destruct IHSTAR as (it & (s2' & ISTAR) & ITR). subst. + move H after ISTAR. inv H. + - exists (it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. + { econstructor 1; eauto. simpl. rewrite ALLOWED in H3. unfold Genv.find_comp_ignore_offset in H3. auto. } + auto. + - pose proof EV as EV0. inv EV0. + + exists (it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. + { econstructor 2; eauto. } + auto. + + assert (CASES: (exists ef, Genv.find_funct_ptr (Genv.globalenv p) b' = Some (External ef)) \/ + ((exists intf, Genv.find_funct_ptr (Genv.globalenv p) b' = Some (Internal intf)) \/ (Genv.find_funct_ptr (Genv.globalenv p) b' = None))). + { destruct (Genv.find_funct_ptr (Genv.globalenv p) b') eqn:CASES; [|auto]. destruct f0; eauto. } + destruct CASES as [EXT | ELSE]. + * exists ((Event_call (comp_of f) (Genv.find_comp_ignore_offset (Genv.globalenv p) (Vptr b' ofs')) i0 vl, info_call is_cross_ext sig) :: it). simpl. split; [|auto]. + exists s2'. econstructor 2. 2: eapply ISTAR. + { econstructor 2; eauto. } + simpl. destruct EXT. rewrite H8. unfold Genv.find_comp_ignore_offset in H. rewrite H. auto. + * exists ((Event_call (comp_of f) (Genv.find_comp_ignore_offset (Genv.globalenv p) (Vptr b' ofs')) i0 vl, info_call not_cross_ext sig) :: it). simpl. split; [|auto]. + exists s2'. econstructor 2. 2: eapply ISTAR. + { econstructor 2; eauto. } + simpl. destruct ELSE. destruct H8. rewrite H8. auto. rewrite H8. auto. + - exists (it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. + { econstructor 3; eauto. } + auto. + - pose proof EV as EV0. inv EV0. + + exists (it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. + { econstructor 4; eauto. } + auto. + + exists ((Event_return (Genv.find_comp_ignore_offset (Genv.globalenv p) (rs PC)) (callee_comp (comp_of_main p) st) res, info_return (sig_of_call st)) :: it). + simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. + { econstructor 4; eauto. } + auto. + - exists ((map (fun e => (e, info_builtin ef)) t1) ++ it). simpl; split. + 2:{ unfold itr_to_tr. rewrite map_app. unfold Eapp. f_equal. rewrite map_map. simpl. apply map_id. } + exists s2'. econstructor 2. 2: eapply ISTAR. + { econstructor 5; eauto. } + auto. + - exists ((map (fun e => (e, info_external b (ef_sig ef))) t1) ++ it). simpl; split. + 2:{ unfold itr_to_tr. rewrite map_app. unfold Eapp. f_equal. rewrite map_map. simpl. apply map_id. } + exists s2'. econstructor 2. 2: eapply ISTAR. + { econstructor 6; eauto. } + auto. + Qed. + + Lemma asm_tr_implies_info_tr + (p: Asm.program) (t: trace) + (HAS: asm_has_initial_trace p t) + : + exists (it: itrace), (asm_has_initial_trace_informative p it) /\ (itr_to_tr it = t). + Proof. + apply semantics_has_initial_trace_prefix_implies_cut in HAS. 2: apply sd_traces; apply Asm.semantics_determinate. + unfold asm_has_initial_trace_informative. inv HAS. + 2:{ exists nil. simpl; split; auto. econstructor 2; auto. } + destruct H0 as (s' & beh & STAR & BEH). exploit asm_star_tr_implies_istar_info_tr; eauto. intros (it & STTRIF & ITRTR). + exists it. split; [|auto]. econstructor 1; eauto. + Qed. + +End ASMITR. From 0ceafcd9a562cda580ad7df4b6c9f166efee802b Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 4 May 2023 16:44:00 +0200 Subject: [PATCH 038/174] WIP --- Makefile | 2 +- security/Backtranslation.v | 207 ++++++++++--------------------------- security/BtInfoAsm.v | 3 +- 3 files changed, 58 insertions(+), 154 deletions(-) diff --git a/Makefile b/Makefile index 8a448e3df1..9a641a5f18 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 Backtranslation.v +SECURITY=RSC.v Split.v Blame.v Recomposition.v BtInfoAsm.v Backtranslation.v # Parser diff --git a/security/Backtranslation.v b/security/Backtranslation.v index fce1dbef6d..a3223084a6 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -5,10 +5,10 @@ Require Import AST Linking Smallstep Events Behaviors. Require Import Split. Require Import riscV.Asm. +Require Import BtInfoAsm. Require Import Ctypes Clight. - Record syscall_properties (sem: extcall_sem) (sg: signature) : Prop := mk_syscall_properties { sc_args_match: @@ -114,88 +114,7 @@ Section GENV. End GENV. - -Section EXTFUN. - - (* Requirements for external call semantics and definitions. *) - - - Definition match_sk_ef_asm (ge: Asm.genv) (sk: sys_kind) (ef: external_function) : Prop := - match sk with - | sys_external id => - exists b, (Genv.find_symbol ge id = Some b) /\ (Genv.find_funct ge (Vptr b Ptrofs.zero) = Some (AST.External ef)) - | sys_builtin name sg => - (ef = EF_builtin name sg) \/ (ef = EF_runtime name sg) - | sys_inline txt sg strs => - (ef = EF_inline_asm txt sg strs) - end. - - Definition match_sk_ef_cl (ge: Clight.genv) (sk: sys_kind) (ef: external_function) : Prop := - match sk with - | sys_external id => - exists b, (Genv.find_symbol ge id = Some b) /\ (exists targs tres cc, Genv.find_funct ge (Vptr b Ptrofs.zero) = Some (External ef targs tres cc)) - | sys_builtin name sg => - (ef = EF_builtin name sg) \/ (ef = EF_runtime name sg) - | sys_inline txt sg strs => - (ef = EF_inline_asm txt sg strs) - end. - - Definition sys_env := string -> option sys_kind. - - Definition wf_sys_env_asm (ske: sys_env): Prop := - forall ef (ge: Asm.genv) cp args m name evargs evres res m' - (DEFINED: external_call ef ge cp args m (Event_syscall name evargs evres :: nil) res m'), - exists sk, - (ske name = Some sk) /\ (match_sk_ef_asm ge sk ef). - - - - - (SEM: external_call ef ge cp (list_eventval_to_list_val (globalenv p) args) m (ev :: nil) srv m') - - - - (* need to handle type: It seems that Asm.step does not utilizes sig, so we need to correctly craft type in Clight.step. - e.g., if we bt everything into void, ok when intra but not when cross. - *) - Definition syscall_properties1 (sem: extcall_sem) : Prop := - forall ge cp vargs m1 name evargs evres vres m2, - sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> - exists vres' m2', - sem ge cp (list_eventval_to_list_val ge evargs) m1 (Event_syscall name evargs evres :: nil) vres' m2'. - - - (* Record syscall_properties1 (sem: extcall_sem) (sg: signature) : Prop := *) - (* mk_syscall_properties { *) - (* sc_args_match: *) - (* forall ge cp vargs m1 name evargs evres vres m2, *) - (* sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> *) - (* sem ge cp (list_eventval_to_list_val ge vargs) m1 (Event_syscall name evargs evres :: nil) vres m2; *) - - (* sc_name_match: *) - (* forall name' ge cp vargs m1 name evargs evres vres m2, *) - (* sem = external_functions_sem name' sg -> *) - (* sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> *) - (* (name' = name); *) - (* }. *) - - (* Record syscall_properties2 (sem: extcall_sem) (sg: signature) : Prop := *) - (* mk_syscall_properties { *) - (* sc_args_match: *) - (* forall ge cp vargs m1 name evargs evres vres m2, *) - (* sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> *) - (* eventval_list_match ge evargs sg.(sig_args) vargs; *) - - (* sc_name_match: *) - (* forall name' ge cp vargs m1 name evargs evres vres m2, *) - (* sem = external_functions_sem name' sg -> *) - (* sem ge cp vargs m1 (Event_syscall name evargs evres :: nil) vres m2 -> *) - (* (name' = name); *) - (* }. *) -End EXTFUN. - - -Section AUX. +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)). @@ -270,7 +189,7 @@ forall b, b is the block of one of the counter -> (* /\ inject_incr f f' *) (* /\ inject_separated f f' m1 m1'; *) -End AUX. +End MEM. Section Backtranslation. @@ -293,8 +212,9 @@ Section Backtranslation. Ltac take_step := econstructor; [econstructor; simpl_expr | | traceEq]; simpl. + Section SWITCH. - (** switch statement; use to convert a trace to a code **) + (** switch statement; used when converting a trace to a code **) Definition type_counter: type := Tlong Unsigned noattr. Definition type_bool: type := Tint IBool Signed noattr. @@ -553,7 +473,7 @@ Section Backtranslation. Section CODEAUX. - (* We extract function data: argument types, fn_return, rn_callconv from signature of Asm.function *) + (* We extract function data: argument types, fn_return, rn_callconv from signature *) (* Correctness should follow from the semantics of Asm, especially eventval_match *) Definition typ_to_type: typ -> type := fun t: typ => @@ -562,7 +482,7 @@ Section Backtranslation. | AST.Tfloat => Tfloat F64 noattr | AST.Tlong => Tlong Signed noattr | AST.Tsingle => Tfloat F32 noattr - (* not appear in eventval_match *) + (* do not appear in eventval_match *) | AST.Tany32 => Tvoid | AST.Tany64 => Tvoid end. @@ -622,75 +542,62 @@ Section Backtranslation. Section CODE. - (** converting trace to code **) + (** converting *informative* trace to code **) + + Context {F: Type}. + Context {V: Type}. + Variable ge: Genv.t F V. (* converting functions *) - Definition code_of_vload (ch: memory_chunk) (id: ident) (ofs: Ptrofs.int) (v: eventval) := - Sbuiltin None (EF_vload ch) (dargs (from_extfun_fun_data (EF_vload ch))) (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) (dargs (from_extfun_fun_data (EF_vstore ch))) ((ptr_of_id_ofs id ofs) :: (eventval_to_expr v) :: nil). - - Definition code_of_annot (str: string) (vs: list eventval) := - let efa := (EF_annot - (Pos.of_nat (List.length (typlist_of_typelist (list_eventval_to_typelist vs)))) - str - (typlist_of_typelist (list_eventval_to_typelist vs)) - ) - in - Sbuiltin None efa (dargs (from_extfun_fun_data efa)) (list_eventval_to_list_expr vs). - - Definition code_of_call (fds: funs_data) (cp cp': compartment) (id: ident) (vs: list eventval) := - let '(targs, tret, cc) := match fds ! id with - | Some data => (dargs data, dret data, dcc data) - | None => (Tnil, Tvoid, cc_default) - end - in - Scall None (Evar id (Tfunction targs tret cc)) (list_eventval_to_list_expr vs). - - (* TODO: syscall_ident should have more information to distinguish below cases: - | EF_external name _ sg => external_functions_sem name sg - | EF_builtin name sg | EF_runtime name sg => builtin_or_external_sem name sg - | EF_inline_asm txt sg _ => inline_assembly_sem txt sg - *) - (* Two cases for invoking an Event_syscall: - 1. cross-compartment. follows a call event, so just a skip is enough. - 2. intra-compartment. need to execute a 'Scall'. We define this case. - *) - (** need function: external call name -> id **) - (** need axiom: 'Event_syscall name _ _' can be uniquely converted into a code (ident). - e.g., an external call to 'EF_external name _ _' invokes 'Event_syscall name _ _'. - **) - Variable sid: string -> option sys_kind. - Definition code_of_syscall (fds: funs_data) (name: string) (vs: list eventval) (v: eventval) := - match (sid name) with - | Some (sys_external id) => - let '(targs, tret, cc) := match fds ! id with - | Some data => (dargs data, dret data, dcc data) - | None => (Tnil, Tvoid, cc_default) - end - in - Scall None (Evar id (Tfunction targs tret cc)) (list_eventval_to_list_expr vs) - | Some (sys_builtin name' sg) => - Sbuiltin None (EF_builtin name' sg) (dargs (from_sig_fun_data sg)) (list_eventval_to_list_expr vs) - | Some (sys_inline txt sg strs) => - Sbuiltin None (EF_inline_asm txt sg strs) (dargs (from_sig_fun_data sg)) (list_eventval_to_list_expr vs) - | None => - Sskip + Definition code_of_external (argsexpr: list expr) (ik: info_kind) := + match ik with + | info_builtin ef => + Sbuiltin None ef (dargs (from_sig_fun_data (ef_sig ef))) argsexpr + | info_external b sg => + match Genv.invert_symbol ge b with + | Some id => + let tys := from_sig_fun_data sg in + Scall None (Evar id (Tfunction (dargs tys) (dret tys) (dcc tys))) argsexpr + | None => Sskip + end + | _ => Sskip end. + Definition code_of_vload (ch: memory_chunk) (id: ident) (ofs: Ptrofs.int) (v: eventval) (ik: info_kind) := + let argsexpr := (ptr_of_id_ofs id ofs :: nil) in code_of_external argsexpr ik. - Definition code_of_return (cp cp': compartment) (v: eventval) := - Sreturn (Some (eventval_to_expr v)). + Definition code_of_vstore (ch: memory_chunk) (id: ident) (ofs: Ptrofs.int) (v: eventval) (ik: info_kind) := + let argsexpr := ((ptr_of_id_ofs id ofs) :: (eventval_to_expr v) :: nil) in code_of_external argsexpr ik. - Definition code_of_event (fds: funs_data) (e: event): statement := + Definition code_of_annot (str: string) (vs: list eventval) (ik: info_kind) := + let argsexpr := (list_eventval_to_list_expr vs) in code_of_external argsexpr ik. + + Definition code_of_syscall (name: string) (vs: list eventval) (v: eventval) (ik: info_kind) := + let argsexpr := (list_eventval_to_list_expr vs) in code_of_external argsexpr ik. + + Definition code_of_call (cp cp': compartment) (id: ident) (vs: list eventval) (ik: info_kind) := + match ik with + | info_call _ sg => + let tys := from_sig_fun_data sg in + Scall None (Evar id (Tfunction (dargs tys) (dret tys) (dcc tys))) (list_eventval_to_list_expr vs) + | _ => Sskip + end. + + Definition code_of_return (cp cp': compartment) (v: eventval) (ik: info_kind) := + match ik with + | info_return _ => + Sreturn (Some (eventval_to_expr v)) + | _ => Sskip + end. + + Definition code_of_ievent (e: ievent): statement := match e with - | 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 fds cp cp' id vs - | Event_syscall name vs v => code_of_syscall fds name vs v - | Event_return cp cp' v => code_of_return cp cp' v + | (Event_vload ch id ofs v, ik) => code_of_vload ch id ofs v ik + | (Event_vstore ch id ofs v, ik) => code_of_vstore ch id ofs v ik + | (Event_annot str vs, ik) => code_of_annot str vs ik + | (Event_call cp cp' id vs, ik) => code_of_call cp cp' id vs ik + | (Event_syscall name vs v, ik) => code_of_syscall name vs v ik + | (Event_return cp cp' v, ik) => code_of_return cp cp' v ik end. (* A while(1)-loop with a big switch inside it *) @@ -938,8 +845,6 @@ Section Backtranslation. Section STEPPROP. - Variable sid: string -> option sys_kind. - (* Step lemmas *) Lemma code_of_event_step_vload ev diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 85e486dd4c..b666b3775b 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -132,8 +132,7 @@ Section INFORMATIVE. Import Smallstep. (* At CROSS-COMP calls, if fundef is ext, set to is_cross_ext. Otherwise is_not_ext. *) - (* Similar at return. *) - (* When a Event_call is is_cross_ext, do not back-translate the following Event_syscall and Event_return. *) + (* When a Event_call is is_cross_ext, do not back-translate the following (possible Event_syscall and) Event_return. *) Variant cross_ext := | is_cross_ext | not_cross_ext. (* Additional information *) From 4ba0e266e7d47c31643ec4aa58fc0c46de029821 Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 5 May 2023 16:21:01 +0200 Subject: [PATCH 039/174] WIP: upgrade step lemmas --- security/Backtranslation.v | 244 +++++++++++++++++++++++++++++++++++-- 1 file changed, 237 insertions(+), 7 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index a3223084a6..f36a9bf01f 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -840,32 +840,262 @@ Section Backtranslation. 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. + End CODEPROP. Section STEPPROP. + Variant external_call_event_match (ef: external_function) (ev: event) (ge: Senv.t) (cp: compartment) (m1: mem) (e: env) (m2: mem): Prop := + | ext_match_vload + ch + (EF: ef = EF_vload ch) + id ofs evv + (EV: ev = Event_vload ch id ofs evv) + (WF: wf_env e id) + b res + (SEM: volatile_load_sem ch ge cp (Vptr b ofs :: nil) m1 (ev :: nil) res m2) + : + external_call_event_match ef ev ge cp m1 e m2 + | ext_match_vstore + ch + (EF: ef = EF_vstore ch) + id ofs evv + (EV: ev = Event_vstore ch id ofs evv) + (WF0: wf_env e id) + (WF1: wf_eventval_env e evv) + b argv + (SEM: volatile_store_sem ch ge cp (Vptr b ofs :: argv :: nil) m1 (ev :: nil) Vundef m2) + : + external_call_event_match ef ev ge cp m1 e m2 + | ext_match_annot + len text targs + (EF: ef = EF_annot len text targs) + evargs + (EV: ev = Event_annot text evargs) + (WFENV: Forall (wf_eventval_env e) evargs) + vargs + (SEM: extcall_annot_sem text targs ge cp vargs m1 (ev :: nil) Vundef m2) + : + external_call_event_match ef ev ge cp m1 e m2 + | ext_match_external + name excp sg + (EF: ef = EF_external name excp sg) + evname evargs evres + (EV: ev = Event_syscall evname evargs evres) + (WFENV: Forall (wf_eventval_env e) evargs) + vargs vres + (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) + (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) + : + external_call_event_match ef ev ge cp m1 e m2 + | ext_match_builtin + name sg + (EF: (ef = EF_builtin name sg) \/ (ef = EF_runtime name sg)) + evname evargs evres + (EV: ev = Event_syscall evname evargs evres) + (WFENV: Forall (wf_eventval_env e) evargs) + (ISEXT: Builtins.lookup_builtin_function name sg = None) + vargs vres + (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) + (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) + : + external_call_event_match ef ev ge cp m1 e m2 + | ext_match_inline_asm + txt sg strs + (EF: ef = EF_inline_asm txt sg strs) + evname evargs evres + (EV: ev = Event_syscall evname evargs evres) + (WFENV: Forall (wf_eventval_env e) evargs) + vargs vres + (SEM: inline_assembly_sem txt sg ge cp vargs m1 (ev :: nil) vres m2) + (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) + : + external_call_event_match ef ev ge cp m1 e m2 + . + (* Step lemmas *) + Lemma code_of_event_step_intra_call_ext + ev ik ef + p f k e le m1 ge cp m2 + (CP: cp = comp_of f) + (GE: ge = globalenv p) + (EXT: external_call_event_match ef ev ge cp m1 e m2) + fb + (IK: ik = info_external fb (ef_sig ef)) + fid + (INV: Genv.invert_symbol ge fb = Some fid) + (WF: wf_env e fid) + (* bt_wf *) + (* from_asm *) + (ISEXT: let tys := from_sig_fun_data (ef_sig ef) in + Genv.find_funct_ptr ge fb = Some (Ctypes.External ef (dargs tys) (dret tys) (dcc tys))) + (ALLOWED: Genv.allowed_call ge cp (Vptr fb Ptrofs.zero)) + (INTRA: Genv.type_of_call ge cp (Genv.find_comp ge (Vptr fb Ptrofs.zero)) <> Genv.CrossCompartmentCall) + : + Star (Clight.semantics1 p) + (State f (code_of_ievent ge (ev, ik)) k e le m1) + (ev :: nil) + (State f Sskip k e le m2). + Proof. + inv EXT; subst; simpl in *. + - pose proof SEM as SEM0. inv SEM. inv H5. rewrite INV. econstructor 2. + { eapply step_call. + 4:{ instantiate (2:=Vptr fb Ptrofs.zero). unfold Genv.find_funct. rewrite pred_dec_true; eauto. } + 4:{ simpl. eauto. } + auto. + { eapply eval_Elvalue. eapply eval_Evar_global; auto. eapply Genv.invert_find_symbol; eauto. simpl. econstructor 2. auto. } + { econstructor; eauto. 3: econstructor. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. eapply sem_cast_ptr. } + auto. + { intros F. simpl in *. contradiction. } + { econstructor 1. auto. } + } + econstructor 2. + { eapply step_external_function. simpl. eauto. } + econstructor 2. + { unfold Genv.find_comp, Genv.find_funct in INTRA. rewrite pred_dec_true in INTRA; auto. rewrite ISEXT in INTRA; simpl in INTRA. unfold comp_of at 2 in INTRA. simpl in INTRA. + eapply step_returnstate; simpl. + - intros F. contradiction. + - econstructor 1. auto. + } + simpl. econstructor 1. all: eauto. + - pose proof SEM as SEM0. inv SEM. inv H5. rewrite INV. econstructor 2. + { eapply step_call. + 4:{ instantiate (2:=Vptr fb Ptrofs.zero). unfold Genv.find_funct. rewrite pred_dec_true; eauto. } + 4:{ simpl. eauto. } + auto. + { eapply eval_Elvalue. eapply eval_Evar_global; auto. eapply Genv.invert_find_symbol; eauto. simpl. econstructor 2. auto. } + { econstructor; eauto. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. eapply sem_cast_ptr. + econstructor; eauto. 3: econstructor. eapply eventval_to_expr_val_eval; auto. eapply eventval_match_wf_eventval_ge; eauto. + eapply eventval_match_sem_cast. erewrite eventval_match_eventval_to_val; eauto. + } + auto. + { intros F. simpl in *. contradiction. } + { econstructor 1. auto. } + } + econstructor 2. + { eapply step_external_function. unfold call_comp. simpl. econstructor. econstructor 1; eauto. eapply val_load_result_aux; eauto. } + econstructor 2. + { unfold Genv.find_comp, Genv.find_funct in INTRA. rewrite pred_dec_true in INTRA; auto. rewrite ISEXT in INTRA; simpl in INTRA. unfold comp_of at 2 in INTRA. simpl in INTRA. + eapply step_returnstate; simpl. + - intros F. contradiction. + - econstructor 1. auto. + } + simpl. econstructor 1. all: eauto. + - pose proof SEM as SEM0. inv SEM. rewrite INV. econstructor 2. + { eapply step_call. + 4:{ instantiate (2:=Vptr fb Ptrofs.zero). unfold Genv.find_funct. rewrite pred_dec_true; eauto. } + 4:{ simpl. eauto. } + auto. + { eapply eval_Elvalue. eapply eval_Evar_global; auto. eapply Genv.invert_find_symbol; eauto. simpl. econstructor 2. auto. } + { eapply list_eventval_to_expr_val_eval_typs; eauto. } + auto. + { intros F. simpl in *. contradiction. } + { econstructor 1. auto. } + } + econstructor 2. + { eapply step_external_function. unfold call_comp. simpl. eauto. } + econstructor 2. + { unfold Genv.find_comp, Genv.find_funct in INTRA. rewrite pred_dec_true in INTRA; auto. rewrite ISEXT in INTRA; simpl in INTRA. unfold comp_of at 2 in INTRA. simpl in INTRA. + eapply step_returnstate; simpl. + - intros F. contradiction. + - econstructor 1. auto. + } + simpl. econstructor 1. all: eauto. + - rewrite INV. econstructor 2. + { eapply step_call. + 4:{ instantiate (2:=Vptr fb Ptrofs.zero). unfold Genv.find_funct. rewrite pred_dec_true; eauto. } + 4:{ simpl. eauto. } + auto. + { eapply eval_Elvalue. eapply eval_Evar_global; auto. eapply Genv.invert_find_symbol; eauto. simpl. econstructor 2. auto. } + { eapply list_eventval_to_expr_val_eval_typs; eauto. } + auto. + { intros F. simpl in *. contradiction. } + { econstructor 1. auto. } + } + econstructor 2. + { eapply step_external_function. unfold call_comp. simpl. eauto. } + econstructor 2. + { unfold Genv.find_comp, Genv.find_funct in INTRA. rewrite pred_dec_true in INTRA; auto. rewrite ISEXT in INTRA; simpl in INTRA. unfold comp_of at 2 in INTRA. simpl in INTRA. + eapply step_returnstate; simpl. + - intros F. contradiction. + - econstructor 1. auto. + } + simpl. econstructor 1. all: eauto. + - rewrite INV. econstructor 2. + { eapply step_call. + 4:{ instantiate (2:=Vptr fb Ptrofs.zero). unfold Genv.find_funct. rewrite pred_dec_true; eauto. } + 4:{ simpl. eauto. } + auto. + { eapply eval_Elvalue. eapply eval_Evar_global; auto. eapply Genv.invert_find_symbol; eauto. simpl. econstructor 2. auto. } + { eapply list_eventval_to_expr_val_eval_typs; eauto. destruct EF; subst; simpl; eauto. } + auto. + { intros F. simpl in *. contradiction. } + { econstructor 1. auto. } + } + econstructor 2. + { eapply step_external_function. unfold call_comp. simpl. destruct EF; subst; simpl; red; rewrite ISEXT0; eauto. } + econstructor 2. + { unfold Genv.find_comp, Genv.find_funct in INTRA. rewrite pred_dec_true in INTRA; auto. rewrite ISEXT in INTRA; simpl in INTRA. unfold comp_of at 2 in INTRA. simpl in INTRA. + eapply step_returnstate; simpl. + - intros F. contradiction. + - econstructor 1. auto. + } + simpl. econstructor 1. all: eauto. + - rewrite INV. econstructor 2. + { eapply step_call. + 4:{ instantiate (2:=Vptr fb Ptrofs.zero). unfold Genv.find_funct. rewrite pred_dec_true; eauto. } + 4:{ simpl. eauto. } + auto. + { eapply eval_Elvalue. eapply eval_Evar_global; auto. eapply Genv.invert_find_symbol; eauto. simpl. econstructor 2. auto. } + { eapply list_eventval_to_expr_val_eval_typs; eauto. } + auto. + { intros F. simpl in *. contradiction. } + { econstructor 1. auto. } + } + econstructor 2. + { eapply step_external_function. unfold call_comp. simpl. eauto. } + econstructor 2. + { unfold Genv.find_comp, Genv.find_funct in INTRA. rewrite pred_dec_true in INTRA; auto. rewrite ISEXT in INTRA; simpl in INTRA. unfold comp_of at 2 in INTRA. simpl in INTRA. + eapply step_returnstate; simpl. + - intros F. contradiction. + - econstructor 1. auto. + } + simpl. econstructor 1. all: eauto. + Qed. + Lemma code_of_event_step_vload - ev + ev ik ch id ofs v - p f k e le m + p f k e le m ge + (GE: ge = globalenv p) (EV: ev = Event_vload ch id ofs v) + fb + (IK: ik = info_external fb (ef_sig (EF_vload ch))) + fid + (EXT: Genv.invert_symbol ge fb = Some fid) (* bt_wf *) (WFENV: wf_env e id) (* from_asm *) b - (VOL: Senv.block_is_volatile (globalenv p) b = true) - (GE: Genv.find_symbol (globalenv p) id = Some b) + (VOL: Senv.block_is_volatile ge b = true) + (SYMB: Genv.find_symbol ge id = Some b) rv - (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) rv) + (MATCH: eventval_match ge v (type_of_chunk ch) rv) : Star (Clight.semantics1 p) - (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) + (State f (code_of_ievent ge (ev, ik)) k e le m) (ev :: nil) (State f Sskip k e le m). Proof. - subst; simpl in *. unfold code_of_vload. simpl. + subst; simpl in *. rewrite EXT. econstructor 2. 3:{ rewrite E0_right. reflexivity. } { eapply step_builtin. From 05d9ff2760c2930f738f1e6a5ce4cb472e589853 Mon Sep 17 00:00:00 2001 From: ldj Date: Sat, 6 May 2023 18:02:50 +0200 Subject: [PATCH 040/174] WIP --- security/Backtranslation.v | 101 +++++++++++++++++++++++++++++++------ 1 file changed, 86 insertions(+), 15 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index f36a9bf01f..71345eb51b 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -853,17 +853,17 @@ Section Backtranslation. Section STEPPROP. - Variant external_call_event_match (ef: external_function) (ev: event) (ge: Senv.t) (cp: compartment) (m1: mem) (e: env) (m2: mem): Prop := + Variant external_call_event_match (ef: external_function) (ev: event) (ge: Senv.t) (cp: compartment) (m1: mem) (e: env) : val -> mem -> Prop := | ext_match_vload ch (EF: ef = EF_vload ch) id ofs evv (EV: ev = Event_vload ch id ofs evv) (WF: wf_env e id) - b res + b res m2 (SEM: volatile_load_sem ch ge cp (Vptr b ofs :: nil) m1 (ev :: nil) res m2) : - external_call_event_match ef ev ge cp m1 e m2 + external_call_event_match ef ev ge cp m1 e res m2 | ext_match_vstore ch (EF: ef = EF_vstore ch) @@ -871,31 +871,31 @@ Section Backtranslation. (EV: ev = Event_vstore ch id ofs evv) (WF0: wf_env e id) (WF1: wf_eventval_env e evv) - b argv + b argv m2 (SEM: volatile_store_sem ch ge cp (Vptr b ofs :: argv :: nil) m1 (ev :: nil) Vundef m2) : - external_call_event_match ef ev ge cp m1 e m2 + external_call_event_match ef ev ge cp m1 e Vundef m2 | ext_match_annot len text targs (EF: ef = EF_annot len text targs) evargs (EV: ev = Event_annot text evargs) (WFENV: Forall (wf_eventval_env e) evargs) - vargs + vargs m2 (SEM: extcall_annot_sem text targs ge cp vargs m1 (ev :: nil) Vundef m2) : - external_call_event_match ef ev ge cp m1 e m2 + external_call_event_match ef ev ge cp m1 e Vundef m2 | ext_match_external name excp sg (EF: ef = EF_external name excp sg) evname evargs evres (EV: ev = Event_syscall evname evargs evres) (WFENV: Forall (wf_eventval_env e) evargs) - vargs vres + vargs vres m2 (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) : - external_call_event_match ef ev ge cp m1 e m2 + external_call_event_match ef ev ge cp m1 e vres m2 | ext_match_builtin name sg (EF: (ef = EF_builtin name sg) \/ (ef = EF_runtime name sg)) @@ -903,31 +903,31 @@ Section Backtranslation. (EV: ev = Event_syscall evname evargs evres) (WFENV: Forall (wf_eventval_env e) evargs) (ISEXT: Builtins.lookup_builtin_function name sg = None) - vargs vres + vargs vres m2 (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) : - external_call_event_match ef ev ge cp m1 e m2 + external_call_event_match ef ev ge cp m1 e vres m2 | ext_match_inline_asm txt sg strs (EF: ef = EF_inline_asm txt sg strs) evname evargs evres (EV: ev = Event_syscall evname evargs evres) (WFENV: Forall (wf_eventval_env e) evargs) - vargs vres + vargs vres m2 (SEM: inline_assembly_sem txt sg ge cp vargs m1 (ev :: nil) vres m2) (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) : - external_call_event_match ef ev ge cp m1 e m2 + external_call_event_match ef ev ge cp m1 e vres m2 . (* Step lemmas *) Lemma code_of_event_step_intra_call_ext ev ik ef - p f k e le m1 ge cp m2 + p f k e le m1 ge cp res m2 (CP: cp = comp_of f) (GE: ge = globalenv p) - (EXT: external_call_event_match ef ev ge cp m1 e m2) + (EXT: external_call_event_match ef ev ge cp m1 e res m2) fb (IK: ik = info_external fb (ef_sig ef)) fid @@ -1071,6 +1071,77 @@ Section Backtranslation. simpl. econstructor 1. all: eauto. Qed. + Lemma code_of_event_step_builtin + ev ik ef + p f k e le m1 ge cp res m2 + (CP: cp = comp_of f) + (GE: ge = globalenv p) + (EXT: external_call_event_match ef ev ge cp m1 e res m2) + (IK: ik = info_builtin ef) + (* bt_wf *) + (* from_asm *) + : + Star (Clight.semantics1 p) + (State f (code_of_ievent ge (ev, ik)) k e le m1) + (ev :: nil) + (State f Sskip k e le m2). + Proof. + inv EXT; subst; simpl in *. + - pose proof SEM as SEM0. inv SEM. inv H5. econstructor 2. + { eapply step_builtin; eauto. + econstructor; eauto. 3: econstructor. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. eapply sem_cast_ptr. + } + simpl. econstructor 1. all: eauto. + - pose proof SEM as SEM0. inv SEM. inv H5. econstructor 2. + { apply val_load_result_aux in H10. + eapply step_builtin. + - econstructor; eauto. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. eapply sem_cast_ptr. + econstructor; eauto. 3: econstructor. eapply eventval_to_expr_val_eval; auto. eapply eventval_match_wf_eventval_ge; eauto. + eapply eventval_match_sem_cast. erewrite eventval_match_eventval_to_val; eauto. + - simpl. econstructor. econstructor 1; eauto. + } + simpl. econstructor 1. all: eauto. + - pose proof SEM as SEM0. inv SEM. econstructor 2. + { eapply step_builtin; eauto. eapply list_eventval_to_expr_val_eval_typs; eauto. } + simpl. econstructor 1. all: eauto. + - econstructor 2. + { eapply step_builtin; eauto. eapply list_eventval_to_expr_val_eval_typs; eauto. } + simpl. econstructor 1. all: eauto. + - econstructor 2. + { destruct EF; subst; simpl. + - eapply step_builtin. eapply list_eventval_to_expr_val_eval_typs; eauto. + simpl. red. rewrite ISEXT. eauto. + - eapply step_builtin. eapply list_eventval_to_expr_val_eval_typs; eauto. + simpl. red. rewrite ISEXT. eauto. + } + simpl. econstructor 1. all: eauto. + - econstructor 2. + { eapply step_builtin; eauto. eapply list_eventval_to_expr_val_eval_typs; eauto. } + simpl. econstructor 1. all: eauto. + Qed. + + Lemma code_of_event_step_cross_call_ext + ev ef + p k m ge cp vres m' + targs tres cconv vargs + (CP: cp = call_comp k) + (GE: ge = globalenv p) + (* (EXT: external_call_event_match ef ev ge cp m1 e res m2) *) + (EXT: external_call ef ge cp vargs m (ev :: nil) vres m') + (* bt_wf *) + (* from_asm *) + : + Star (Clight.semantics1 p) + (Callstate (External ef targs tres cconv) vargs k m) + (ev :: nil) + (Returnstate vres k m' (rettype_of_type tres) (comp_of ef)). + Proof. + subst; simpl in *. econstructor 2. eapply step_external_function. eauto. + econstructor 1. auto. + Qed. + + (* TODO *) + Lemma code_of_event_step_vload ev ik ch id ofs v From 391615c97e1ae9c9fe20282672b587d591190ea6 Mon Sep 17 00:00:00 2001 From: ldj Date: Sat, 6 May 2023 19:27:00 +0200 Subject: [PATCH 041/174] WIP --- security/Backtranslation.v | 168 ++++++++++++++++++++++++++++++++++++- 1 file changed, 167 insertions(+), 1 deletion(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 71345eb51b..fe3cc6cbab 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1126,7 +1126,6 @@ Section Backtranslation. targs tres cconv vargs (CP: cp = call_comp k) (GE: ge = globalenv p) - (* (EXT: external_call_event_match ef ev ge cp m1 e res m2) *) (EXT: external_call ef ge cp vargs m (ev :: nil) vres m') (* bt_wf *) (* from_asm *) @@ -1140,7 +1139,174 @@ Section Backtranslation. econstructor 1. auto. Qed. + Lemma code_of_event_step_cross_call_start + ev ik + p f k e le m ge cp + (CP: cp = comp_of f) + (GE: ge = globalenv p) + cp' fid evargs + (EV: ev = Event_call cp cp' fid evargs) + ce sg + (IK: ik = info_call ce sg) + (WF0: wf_env e fid) + (WF1: Forall (wf_eventval_env e) evargs) + tdata + (TD: tdata = from_sig_fun_data sg) + args + (ARGS: args = list_eventval_to_list_val ge evargs) + b + (FINDB: Genv.find_symbol ge fid = Some b) + fd + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (TYPEF: type_of_fundef fd = Tfunction tdata.(dargs) tdata.(dret) tdata.(dcc)) + (CP': cp' = comp_of fd) + (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) + (NPTR: Forall not_ptr args) + (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) + (ESM: eventval_list_match ge evargs (sig_args sg) args) + : + Star (Clight.semantics1 p) + (State f (code_of_ievent ge (ev, ik)) k e le m) + (ev :: nil) + (Callstate fd args (Kcall None f e le k) m). + Proof. + subst; simpl. econstructor 2. + { eapply step_call. 4: eauto. all: simpl; eauto. + { econstructor. econstructor 2; eauto. simpl. econstructor 2; auto. } + { eapply list_eventval_to_expr_val_eval_typs; auto. } + { red. auto. } + { econstructor 2; eauto. + - unfold Genv.find_comp. setoid_rewrite FINDF. auto. + - eapply Genv.find_invert_symbol; eauto. + - eapply eventval_list_match_transl; eauto. + } + } + { econstructor 1. } + { simpl. unfold Genv.find_comp. + unfold Genv.find_funct in *. simpl in *. rewrite FINDF. auto. + } + Qed. + + + Lemma code_of_event_step_cross_call_int + Lemma code_of_event_step_cross_return_start + Lemma code_of_event_step_cross_returnstate + (* TODO *) + Lemma code_of_event_step_call_start + ev + cp cp' id vs + p f k e le m + ge data + (GE: ge = globalenv p) + (EV: ev = Event_call cp cp' id vs) + (FDATA: (from_cl_funs_data p) ! id = Some data) + (* bt_wf *) + (GLOB: e ! id = None) + (WFARGS1: Forall (wf_eventval_env e) vs) + (* from_asm *) + b + (FINDB: Genv.find_symbol ge id = Some b) + fd + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (TYPEF: type_of_fundef fd = Tfunction data.(dargs) data.(dret) data.(dcc)) + (CP1: cp = comp_of f) + (CP2: cp' = comp_of fd) + (CROSS: Genv.type_of_call ge (comp_of f) (comp_of fd) = Genv.CrossCompartmentCall) + (NPTR: Forall not_ptr (list_eventval_to_list_val ge vs)) + (ALLOW: Genv.allowed_cross_call ge (comp_of f) (Vptr b Ptrofs.zero)) + some_sig_args some_vals + (ESM: eventval_list_match ge vs some_sig_args some_vals) + (SIGARGS: data.(dargs) = (list_typ_to_typelist some_sig_args)) + : + Star (Clight.semantics1 p) + (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) + (ev :: nil) + (Callstate fd (list_eventval_to_list_val ge vs) (Kcall None f e le k) m). + Proof. + subst; simpl. unfold code_of_call. rewrite FDATA. + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_call; simpl; eauto. + { eapply eval_Elvalue. + - eapply eval_Evar_global; eauto. + - eapply deref_loc_reference. auto. + } + { rewrite SIGARGS. apply list_eventval_to_expr_val_eval; auto. eapply eventval_list_match_transl. eauto. } + red; auto. + unfold Genv.find_comp. setoid_rewrite FINDF. + eapply call_trace_cross; eauto. apply Genv.find_invert_symbol; auto. + rewrite SIGARGS. eapply eventval_list_match_transl; eauto. + } + econstructor 1. + Qed. + + Lemma code_of_event_step_return + ev + cp cp' rv + p f k e le m + ge + (GE: ge = globalenv p) + (EV: ev = Event_return cp' cp rv) + (* bt should ensure them *) + (WFRV1: wf_eventval_env e rv) + (* asm should ensure them *) + (NPTR: not_ptr (eventval_to_val ge rv)) + some_sig_ret some_val + (EM: eventval_match ge rv some_sig_ret some_val) + (RTTYP: fn_return f = typ_to_type some_sig_ret) + (* handle during proving *) + optid f' e' le' k' + (CONT: call_cont k = Kcall optid f' e' le' k') + (CP1: cp = comp_of f) + (CP2: cp' = comp_of f') + (CROSS: Genv.type_of_call ge (comp_of f') (comp_of f) = Genv.CrossCompartmentCall) + m' + (FREE: Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m') + : + Star (Clight.semantics1 p) + (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) + (ev :: nil) + (State f' Sskip k' e' (set_opttemp optid (eventval_to_val ge rv) le') m'). + Proof. + subst; simpl. unfold code_of_return. + econstructor 2. + 3:{ rewrite E0_left. reflexivity. } + { eapply step_return_1; simpl; eauto. + { eapply eventval_to_expr_val_eval; auto. eapply eventval_match_wf_eventval_ge; eauto. } + { rewrite RTTYP. eapply sem_cast_eventval_match. eapply eventval_match_transl; eauto. } + } + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { rewrite CONT. eapply step_returnstate; auto. + econstructor 2; auto. rewrite RTTYP. apply eventval_match_proj_rettype. erewrite eventval_match_eventval_to_val; eauto. + } + econstructor 1. + Qed. + + Lemma code_of_event_step_call_internal + p f k e le m + ge + (GE: ge = globalenv p) + (* bt should ensure them *) + fd args f1 + (INTERNAL: fd = Internal f1) + (* asm should ensure them *) + (* handle during proving *) + e1 le1 m1 + (ENTRY: function_entry1 ge f1 args m e1 le1 m1) + : + Star (Clight.semantics1 p) + (Callstate fd args (Kcall None f e le k) m) + nil + (State f1 (fn_body f1) (Kcall None f e le k) e1 le1 m1). + Proof. + subst; simpl. + econstructor 2. + 3:{ rewrite E0_right. reflexivity. } + { eapply step_internal_function; eauto. } + econstructor 1. + Qed. Lemma code_of_event_step_vload ev ik From 5f36255b4c488f611cee8bf8fbce1a5575c582ae Mon Sep 17 00:00:00 2001 From: ldj Date: Sun, 7 May 2023 14:46:18 +0200 Subject: [PATCH 042/174] fixed rettype to type; proved step lemmas --- security/Backtranslation.v | 675 +++++++++---------------------------- 1 file changed, 153 insertions(+), 522 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index fe3cc6cbab..799b5e3395 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -496,14 +496,55 @@ Section Backtranslation. Definition rettype_to_type: rettype -> type := fun rt: rettype => match rt with - | Tint8signed => Tint I8 Signed noattr - | Tint8unsigned => Tint I8 Unsigned noattr - | Tint16signed => Tint I16 Signed noattr - | Tint16unsigned => Tint I16 Unsigned noattr - | AST.Tvoid => Tvoid + | Tint8signed | Tint8unsigned | Tint16signed | Tint16unsigned => Tint I32 Signed noattr + | AST.Tvoid => Tint I32 Signed noattr | Tret t => typ_to_type t end. + (* Definition rettype_to_type: rettype -> type := *) + (* fun rt: rettype => *) + (* match rt with *) + (* | Tint8signed => Tint I8 Signed noattr *) + (* | Tint8unsigned => Tint I8 Unsigned noattr *) + (* | Tint16signed => Tint I16 Signed noattr *) + (* | Tint16unsigned => Tint I16 Unsigned noattr *) + (* | AST.Tvoid => Tvoid *) + (* | 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) + : + (* (rettype_of_type (rettype_to_type rt)) = rt. *) + 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. + + (* Lemma retttype_to_type_rettype_of_type_eq *) + (* ge evres rt res *) + (* (EVM: eventval_match ge evres (proj_rettype rt) res) *) + (* : *) + (* (rettype_of_type (rettype_to_type rt)) = 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 *) (* Definition fun_data : Type := (typelist * type * calling_convention). *) Record fun_data : Type := mkfundata { dargs: typelist; dret: type; dcc: calling_convention }. @@ -538,6 +579,17 @@ Section Backtranslation. let defs := Genv.genv_defs (genv_genv (globalenv cl)) in PTree.map_filter1 from_clgd_fun_data defs. + (* (* Return case *) *) + (* Definition eventval_to_expr_return (v: eventval) (rt: rettype): expr := *) + (* let ty := rettype_to_type rt in *) + (* match v with *) + (* | EVint i => Econst_int i ty *) + (* | EVlong i => Econst_long i ty *) + (* | EVfloat f => Econst_float f ty *) + (* | EVsingle f => Econst_single f ty *) + (* | EVptr_global id ofs => ptr_of_id_ofs id ofs *) + (* end. *) + End CODEAUX. @@ -590,6 +642,13 @@ Section Backtranslation. | _ => Sskip end. + (* Definition code_of_return (cp cp': compartment) (v: eventval) (ik: info_kind) := *) + (* match ik with *) + (* | info_return sg => *) + (* Sreturn (Some (eventval_to_expr_return v (sig_res sg))) *) + (* | _ => Sskip *) + (* end. *) + Definition code_of_ievent (e: ievent): statement := match e with | (Event_vload ch id ofs v, ik) => code_of_vload ch id ofs v ik @@ -848,6 +907,44 @@ Section Backtranslation. unfold Tptr. destruct Archi.ptr64 eqn:ARCH; unfold Cop.sem_cast; simpl; rewrite ARCH; auto. Qed. + Lemma sem_cast_proj_rettype + (ge: cgenv) 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. + End CODEPROP. @@ -1187,550 +1284,84 @@ Section Backtranslation. } Qed. - Lemma code_of_event_step_cross_call_int - Lemma code_of_event_step_cross_return_start - Lemma code_of_event_step_cross_returnstate - - (* TODO *) - Lemma code_of_event_step_call_start - ev - cp cp' id vs - p f k e le m - ge data - (GE: ge = globalenv p) - (EV: ev = Event_call cp cp' id vs) - (FDATA: (from_cl_funs_data p) ! id = Some data) - (* bt_wf *) - (GLOB: e ! id = None) - (WFARGS1: Forall (wf_eventval_env e) vs) - (* from_asm *) - b - (FINDB: Genv.find_symbol ge id = Some b) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (TYPEF: type_of_fundef fd = Tfunction data.(dargs) data.(dret) data.(dcc)) - (CP1: cp = comp_of f) - (CP2: cp' = comp_of fd) - (CROSS: Genv.type_of_call ge (comp_of f) (comp_of fd) = Genv.CrossCompartmentCall) - (NPTR: Forall not_ptr (list_eventval_to_list_val ge vs)) - (ALLOW: Genv.allowed_cross_call ge (comp_of f) (Vptr b Ptrofs.zero)) - some_sig_args some_vals - (ESM: eventval_list_match ge vs some_sig_args some_vals) - (SIGARGS: data.(dargs) = (list_typ_to_typelist some_sig_args)) + p f vargs k m1 m2 e le + (ENT: function_entry1 (globalenv p) f vargs m1 e le m2) : - Star (Clight.semantics1 p) - (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) - (ev :: nil) - (Callstate fd (list_eventval_to_list_val ge vs) (Kcall None f e le k) m). + Star (Clight.semantics1 p) + (Callstate (Internal f) vargs k m1) + (nil) + (State f (fn_body f) k e le m2). Proof. - subst; simpl. unfold code_of_call. rewrite FDATA. - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_call; simpl; eauto. - { eapply eval_Elvalue. - - eapply eval_Evar_global; eauto. - - eapply deref_loc_reference. auto. - } - { rewrite SIGARGS. apply list_eventval_to_expr_val_eval; auto. eapply eventval_list_match_transl. eauto. } - red; auto. - unfold Genv.find_comp. setoid_rewrite FINDF. - eapply call_trace_cross; eauto. apply Genv.find_invert_symbol; auto. - rewrite SIGARGS. eapply eventval_list_match_transl; eauto. - } - econstructor 1. + subst; simpl in *. econstructor 2. eapply step_internal_function. eauto. + econstructor 1. auto. Qed. - Lemma code_of_event_step_return - ev - cp cp' rv - p f k e le m - ge + Lemma code_of_event_step_cross_returnstate + ev ik sg evres + p ge res optid f e le k m ty cp (GE: ge = globalenv p) - (EV: ev = Event_return cp' cp rv) - (* bt should ensure them *) - (WFRV1: wf_eventval_env e rv) - (* asm should ensure them *) - (NPTR: not_ptr (eventval_to_val ge rv)) - some_sig_ret some_val - (EM: eventval_match ge rv some_sig_ret some_val) - (RTTYP: fn_return f = typ_to_type some_sig_ret) - (* handle during proving *) - optid f' e' le' k' - (CONT: call_cont k = Kcall optid f' e' le' k') - (CP1: cp = comp_of f) - (CP2: cp' = comp_of f') - (CROSS: Genv.type_of_call ge (comp_of f') (comp_of f) = Genv.CrossCompartmentCall) - m' - (FREE: Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m') + (EV: ev = Event_return (comp_of f) cp evres) + (IK: ik = info_return sg) + (CROSS: Genv.type_of_call ge (comp_of f) cp = Genv.CrossCompartmentCall) + (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) res) + (NPTR: not_ptr res) + (RETTY: ty = sig_res sg) : Star (Clight.semantics1 p) - (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) + (Returnstate res (Kcall optid f e le k) m ty cp) (ev :: nil) - (State f' Sskip k' e' (set_opttemp optid (eventval_to_val ge rv) le') m'). - Proof. - subst; simpl. unfold code_of_return. - econstructor 2. - 3:{ rewrite E0_left. reflexivity. } - { eapply step_return_1; simpl; eauto. - { eapply eventval_to_expr_val_eval; auto. eapply eventval_match_wf_eventval_ge; eauto. } - { rewrite RTTYP. eapply sem_cast_eventval_match. eapply eventval_match_transl; eauto. } - } - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { rewrite CONT. eapply step_returnstate; auto. - econstructor 2; auto. rewrite RTTYP. apply eventval_match_proj_rettype. erewrite eventval_match_eventval_to_val; eauto. - } - econstructor 1. - Qed. - - Lemma code_of_event_step_call_internal - p f k e le m - ge - (GE: ge = globalenv p) - (* bt should ensure them *) - fd args f1 - (INTERNAL: fd = Internal f1) - (* asm should ensure them *) - (* handle during proving *) - e1 le1 m1 - (ENTRY: function_entry1 ge f1 args m e1 le1 m1) - : - Star (Clight.semantics1 p) - (Callstate fd args (Kcall None f e le k) m) - nil - (State f1 (fn_body f1) (Kcall None f e le k) e1 le1 m1). + (State f Sskip k e (set_opttemp optid res le) m). Proof. - subst; simpl. - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_internal_function; eauto. } - econstructor 1. + subst; simpl. econstructor 2. + { eapply step_returnstate; eauto. econstructor 2; eauto. } + econstructor 1. auto. Qed. - Lemma code_of_event_step_vload + Lemma code_of_event_step_cross_return_code ev ik - ch id ofs v - p f k e le m ge - (GE: ge = globalenv p) - (EV: ev = Event_vload ch id ofs v) - fb - (IK: ik = info_external fb (ef_sig (EF_vload ch))) - fid - (EXT: Genv.invert_symbol ge fb = Some fid) - (* bt_wf *) - (WFENV: wf_env e id) - (* from_asm *) - b - (VOL: Senv.block_is_volatile ge b = true) - (SYMB: Genv.find_symbol ge id = Some b) - rv - (MATCH: eventval_match ge v (type_of_chunk ch) rv) - : - Star (Clight.semantics1 p) - (State f (code_of_ievent ge (ev, ik)) k e le m) - (ev :: nil) - (State f Sskip k e le m). - Proof. - subst; simpl in *. rewrite EXT. - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_builtin. - { econstructor; eauto. 3: econstructor. - - eapply ptr_of_id_ofs_eval; eauto. - - destruct Archi.ptr64 eqn:ARCH. - + unfold ptr_of_id_ofs, Tptr. rewrite ARCH. simpl. unfold Cop.sem_cast. simpl. rewrite ARCH. eauto. - + unfold ptr_of_id_ofs, Tptr. rewrite ARCH. simpl. unfold Cop.sem_cast. simpl. rewrite ARCH. eauto. - } - repeat econstructor; eauto. - } - econstructor 1. - Qed. - - Lemma code_of_event_step_vstore - ev - ch id ofs v - p f k e le m - (EV: ev = Event_vstore ch id ofs v) - (* bt_wf *) - (WFENV: wf_env e id) - (WFSV1: wf_eventval_env e v) - (* from_asm *) - b - (VOL: Senv.block_is_volatile (globalenv p) b = true) - (GE: Genv.find_symbol (globalenv p) id = Some b) - vv - (MATCH: eventval_match (globalenv p) v (type_of_chunk ch) (Val.load_result ch vv)) - : - Star (Clight.semantics1 p) - (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) - (ev :: nil) - (State f Sskip k e le m). - Proof. - apply val_load_result_aux in MATCH. - subst; simpl in *. unfold code_of_vstore. - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_builtin. - { econstructor; eauto. - { eapply ptr_of_id_ofs_eval; eauto. } - { destruct Archi.ptr64 eqn:ARCH. - - unfold ptr_of_id_ofs, Tptr. rewrite ARCH; simpl. unfold Cop.sem_cast. simpl. rewrite ARCH. eauto. - - unfold ptr_of_id_ofs, Tptr. rewrite ARCH; simpl. unfold Cop.sem_cast. simpl. rewrite ARCH. eauto. - } - econstructor; eauto. 3: econstructor. - { eapply eventval_to_expr_val_eval; auto. eapply eventval_match_wf_eventval_ge; eauto. } - { eapply sem_cast_eventval_match; eauto. eapply eventval_match_transl. eauto. } - } - simpl. repeat econstructor; eauto. - } - econstructor 1. - Qed. - - Lemma code_of_event_step_annot - ev - str vs - p f k e le m - (EV: ev = Event_annot str vs) - (* bt_wf *) - (WFENV: Forall (wf_eventval_env e) vs) - (* from_asm *) - targs vargs - (ESM: eventval_list_match (globalenv p) vs targs vargs) - : - Star (Clight.semantics1 p) - (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) - (ev :: nil) - (State f Sskip k e le m). - Proof. - subst; simpl in *. unfold code_of_annot. - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_builtin; simpl. - { eapply list_eventval_to_expr_val_eval; auto. eapply eventval_list_match_transl. eapply list_eventval_match_eventval_to_type; eauto. } - { repeat econstructor; eauto. eapply list_eventval_match_eventval_to_type. eapply eventval_list_match_transl; eauto. } - } - econstructor 1. - Qed. - - Lemma code_of_event_step_call_start - ev - cp cp' id vs - p f k e le m - ge data - (GE: ge = globalenv p) - (EV: ev = Event_call cp cp' id vs) - (FDATA: (from_cl_funs_data p) ! id = Some data) - (* bt_wf *) - (GLOB: e ! id = None) - (WFARGS1: Forall (wf_eventval_env e) vs) - (* from_asm *) - b - (FINDB: Genv.find_symbol ge id = Some b) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (TYPEF: type_of_fundef fd = Tfunction data.(dargs) data.(dret) data.(dcc)) - (CP1: cp = comp_of f) - (CP2: cp' = comp_of fd) - (CROSS: Genv.type_of_call ge (comp_of f) (comp_of fd) = Genv.CrossCompartmentCall) - (NPTR: Forall not_ptr (list_eventval_to_list_val ge vs)) - (ALLOW: Genv.allowed_cross_call ge (comp_of f) (Vptr b Ptrofs.zero)) - some_sig_args some_vals - (ESM: eventval_list_match ge vs some_sig_args some_vals) - (SIGARGS: data.(dargs) = (list_typ_to_typelist some_sig_args)) - : - Star (Clight.semantics1 p) - (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) - (ev :: nil) - (Callstate fd (list_eventval_to_list_val ge vs) (Kcall None f e le k) m). - Proof. - subst; simpl. unfold code_of_call. rewrite FDATA. - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_call; simpl; eauto. - { eapply eval_Elvalue. - - eapply eval_Evar_global; eauto. - - eapply deref_loc_reference. auto. - } - { rewrite SIGARGS. apply list_eventval_to_expr_val_eval; auto. eapply eventval_list_match_transl. eauto. } - red; auto. - unfold Genv.find_comp. setoid_rewrite FINDF. - eapply call_trace_cross; eauto. apply Genv.find_invert_symbol; auto. - rewrite SIGARGS. eapply eventval_list_match_transl; eauto. - } - econstructor 1. - Qed. - - Lemma code_of_event_step_return - ev - cp cp' rv - p f k e le m - ge + p f k e le m ge cp + (CP: cp = comp_of f) (GE: ge = globalenv p) - (EV: ev = Event_return cp' cp rv) - (* bt should ensure them *) - (WFRV1: wf_eventval_env e rv) - (* asm should ensure them *) - (NPTR: not_ptr (eventval_to_val ge rv)) - some_sig_ret some_val - (EM: eventval_match ge rv some_sig_ret some_val) - (RTTYP: fn_return f = typ_to_type some_sig_ret) - (* handle during proving *) - optid f' e' le' k' - (CONT: call_cont k = Kcall optid f' e' le' k') - (CP1: cp = comp_of f) - (CP2: cp' = comp_of f') - (CROSS: Genv.type_of_call ge (comp_of f') (comp_of f) = Genv.CrossCompartmentCall) + cp_c evres + (EV: ev = Event_return cp_c cp evres) + (WF: wf_eventval_env e evres) + sg + (IK: ik = info_return sg) + (CROSS: Genv.type_of_call ge cp_c cp = Genv.CrossCompartmentCall) + optid f_c e_c le_c k_c + (CONT: call_cont k = Kcall optid f_c e_c le_c k_c) + (CPC: cp_c = comp_of f_c) + res + (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) res) + (NPTR: not_ptr res) + (TY: fn_return f = rettype_to_type (sig_res sg)) m' - (FREE: Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m') + (FREE: Mem.free_list m (blocks_of_env ge e) cp = Some m') : Star (Clight.semantics1 p) - (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) + (State f (code_of_ievent ge (ev, ik)) k e le m) (ev :: nil) - (State f' Sskip k' e' (set_opttemp optid (eventval_to_val ge rv) le') m'). + (State f_c Sskip k_c e_c (set_opttemp optid res le_c) m'). Proof. - subst; simpl. unfold code_of_return. + subst; simpl. exploit eventval_match_eventval_to_val. eapply EVM. intros RES. econstructor 2. - 3:{ rewrite E0_left. reflexivity. } - { eapply step_return_1; simpl; eauto. + { eapply step_return_1; eauto. { eapply eventval_to_expr_val_eval; auto. eapply eventval_match_wf_eventval_ge; eauto. } - { rewrite RTTYP. eapply sem_cast_eventval_match. eapply eventval_match_transl; eauto. } - } - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { rewrite CONT. eapply step_returnstate; auto. - econstructor 2; auto. rewrite RTTYP. apply eventval_match_proj_rettype. erewrite eventval_match_eventval_to_val; eauto. + { rewrite TY. eapply sem_cast_proj_rettype. eauto. } } - econstructor 1. - Qed. - - Lemma code_of_event_step_call_internal - p f k e le m - ge - (GE: ge = globalenv p) - (* bt should ensure them *) - fd args f1 - (INTERNAL: fd = Internal f1) - (* asm should ensure them *) - (* handle during proving *) - e1 le1 m1 - (ENTRY: function_entry1 ge f1 args m e1 le1 m1) - : - Star (Clight.semantics1 p) - (Callstate fd args (Kcall None f e le k) m) - nil - (State f1 (fn_body f1) (Kcall None f e le k) e1 le1 m1). - Proof. - subst; simpl. - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_internal_function; eauto. } - econstructor 1. - Qed. - - Lemma code_of_event_step_call_external_cross - p m - ge - (GE: ge = globalenv p) - (* bt should ensure them *) - fd k args ef targs tres cconv - (EXTERNAL: fd = External ef targs tres cconv) - (* asm should ensure them *) - sev - vres m1 - (SEM: external_call ef ge (call_comp k) args m (sev :: nil) vres m1) - (* handle during proving *) - sname sargs svr - (SYSEV: sev = Event_syscall sname sargs svr) - : - Star (Clight.semantics1 p) - (Callstate fd args k m) - (sev :: nil) - (Returnstate vres k m1 (rettype_of_type tres) (comp_of ef)). - Proof. - subst; simpl. - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_external_function; eauto. } - econstructor 1. - Qed. - - Lemma code_of_event_step_return_external_cross - p m - ge - (GE: ge = globalenv p) - ev rv f cp - (EV: ev = Event_return (comp_of f) cp rv) - (* bt should ensure them *) - (* asm should ensure them *) - vres optid e le k ty - (CROSS: Genv.type_of_call ge (comp_of f) cp = Genv.CrossCompartmentCall) - (NPTR: not_ptr vres) - (EM: eventval_match ge rv (proj_rettype ty) vres) - (* handle during proving *) - : - Star (Clight.semantics1 p) - (Returnstate vres (Kcall optid f e le k) m ty cp) - (ev :: nil) - (State f Sskip k e (set_opttemp optid vres le) m). - Proof. - subst; simpl. econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_returnstate; eauto. econstructor 2; eauto. } - econstructor 1. - Qed. - - - (* TODO *) - Lemma code_of_event_step_call_external_intra - ev - name args rv - p f k e le m - ge data - (GE: ge = globalenv p) - (EV: ev = Event_syscall name args rv) - (* start call *) - id - (ID: sid name = Some (sys_external id)) - (FDATA: (from_cl_funs_data p) ! id = Some data) - (* bt_wf *) - (GLOB: e ! id = None) - (WFARGS1: Forall (wf_eventval_env e) args) - (* (WFARGS2: Forall (wf_eventval_ge ge) args) *) - (* from_asm *) - b - (FINDB: Genv.find_symbol ge id = Some b) - (ALLOW: Genv.allowed_call ge (comp_of f) (Vptr b Ptrofs.zero)) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (TYPEF: type_of_fundef fd = Tfunction data.(dargs) data.(dret) data.(dcc)) - cp cp' - (CP1: cp = comp_of f) - (CP2: cp' = comp_of fd) - (INTRA: Genv.type_of_call ge (comp_of f) (comp_of fd) <> Genv.CrossCompartmentCall) - (* invoke syscall *) - ef - (* name' cp'' sg *) - (* (EF: ef = EF_external name' cp'' sg) *) - (EXTERNAL: fd = External ef data.(dargs) data.(dret) data.(dcc)) - srv m' - (SEM: external_call ef ge cp (list_eventval_to_list_val (globalenv p) args) m (ev :: nil) srv m') - (* returnstate *) - (* conditions for argument types - might need extra semantics for EF_external *) - (* (TYARGS: data.(dargs) = (list_eventval_to_typelist args)) *) - some_sig_args some_vals - (ESM: eventval_list_match ge args some_sig_args some_vals) - (SIGARGS: data.(dargs) = (list_typ_to_typelist some_sig_args)) - : - Star (Clight.semantics1 p) - (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) - (ev :: nil) - (State f Sskip k e le m'). - Proof. - subst; simpl. unfold code_of_syscall. rewrite ID. rewrite FDATA. - econstructor 2. - 3:{ rewrite E0_left. reflexivity. } - { eapply step_call. simpl; eauto. - { eapply eval_Elvalue. - - eapply eval_Evar_global; eauto. - - eapply deref_loc_reference. auto. - } - (* { rewrite TYARGS. eapply list_eventval_to_expr_val_eval2; auto. } *) - { rewrite SIGARGS. instantiate (1:=list_eventval_to_list_val (globalenv p) args). - eapply list_eventval_to_expr_val_eval_typs; auto. eapply eventval_list_match_transl_val; eauto. + { rewrite CONT. eapply step_returnstate. + { subst res. auto. } + { econstructor 2; auto. rewrite TY. erewrite proj_rettype_to_type_rettype_of_type_eq. + 2: eauto. subst res; eauto. } - all: simpl in *; eauto. - { unfold Genv.find_comp. unfold Genv.find_funct. - rewrite pred_dec_true; auto. rewrite pred_dec_true in FINDF; auto. - rewrite FINDF. intros. exfalso. apply INTRA. auto. - } - { econstructor 1. unfold Genv.find_comp. unfold Genv.find_funct. - rewrite pred_dec_true; auto. rewrite pred_dec_true in FINDF; auto. - rewrite FINDF. intros H. apply INTRA. auto. - } - } - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_external_function. eauto. } - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_returnstate. intro. exfalso. apply INTRA. auto. - econstructor 1. intros H. apply INTRA. auto. } - econstructor 1. - Qed. - - Lemma code_of_event_step_builtin - ev - name args rv - p f k e le m - ge - (GE: ge = globalenv p) - (EV: ev = Event_syscall name args rv) - name' sg - (ID: sid name = Some (sys_builtin name' sg)) - (* bt_wf *) - (WFARGS: Forall (wf_eventval_env e) args) - (* from_asm *) - (* invoke syscall *) - ef - (EF: ef = EF_builtin name' sg) - srv m' - (SEM: external_call ef ge (comp_of f) (list_eventval_to_list_val (globalenv p) args) m (ev :: nil) srv m') - (* conditions for argument types - might need extra semantics for EF_external *) - (* (TYARGS: data.(dargs) = (list_eventval_to_typelist args)) *) - some_sig_args some_vals - (ESM: eventval_list_match ge args some_sig_args some_vals) - (SIGARGS: sg.(sig_args) = (some_sig_args)) - : - Star (Clight.semantics1 p) - (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) - (ev :: nil) - (State f Sskip k e le m'). - Proof. - subst; simpl. unfold code_of_syscall. rewrite ID. - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_builtin; simpl; eauto. eapply list_eventval_to_expr_val_eval_typs; auto. eapply eventval_list_match_transl_val; eauto. } - econstructor 1. - Qed. - - Lemma code_of_event_step_inline - ev - name args rv - p f k e le m - ge - (GE: ge = globalenv p) - (EV: ev = Event_syscall name args rv) - txt sg strs - (ID: sid name = Some (sys_inline txt sg strs)) - (* bt_wf *) - (WFARGS: Forall (wf_eventval_env e) args) - (* from_asm *) - (* invoke syscall *) - ef - (EF: ef = EF_inline_asm txt sg strs) - srv m' - (SEM: external_call ef ge (comp_of f) (list_eventval_to_list_val (globalenv p) args) m (ev :: nil) srv m') - (* conditions for argument types - might need extra semantics for EF_external *) - (* (TYARGS: data.(dargs) = (list_eventval_to_typelist args)) *) - some_sig_args some_vals - (ESM: eventval_list_match ge args some_sig_args some_vals) - (SIGARGS: sg.(sig_args) = (some_sig_args)) - : - Star (Clight.semantics1 p) - (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) - (ev :: nil) - (State f Sskip k e le m'). - Proof. - subst; simpl. unfold code_of_syscall. rewrite ID. - econstructor 2. - 3:{ rewrite E0_right. reflexivity. } - { eapply step_builtin; simpl; eauto. eapply list_eventval_to_expr_val_eval_typs; auto. eapply eventval_list_match_transl_val; eauto. } - econstructor 1. + { subst res. econstructor 1. } + all: eauto. Qed. + (* TODO *) End STEPPROP. From 5d7a2e72518912fdf2b37488892e5aa629578bbe Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 8 May 2023 17:03:22 +0200 Subject: [PATCH 043/174] WIP --- security/Backtranslation.v | 433 +++++++++++++++++++++++++++++++++---- 1 file changed, 386 insertions(+), 47 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 799b5e3395..dc8998c398 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -950,74 +950,168 @@ Section Backtranslation. Section STEPPROP. - Variant external_call_event_match (ef: external_function) (ev: event) (ge: Senv.t) (cp: compartment) (m1: mem) (e: env) : val -> mem -> Prop := + Variant external_call_event_match_common + (ef: external_function) (ev: event) (ge: Senv.t) (cp: compartment) (m1: mem) + : val -> mem -> Prop := | ext_match_vload ch (EF: ef = EF_vload ch) id ofs evv (EV: ev = Event_vload ch id ofs evv) - (WF: wf_env e id) b res m2 (SEM: volatile_load_sem ch ge cp (Vptr b ofs :: nil) m1 (ev :: nil) res m2) : - external_call_event_match ef ev ge cp m1 e res m2 + external_call_event_match_common ef ev ge cp m1 res m2 | ext_match_vstore ch (EF: ef = EF_vstore ch) id ofs evv (EV: ev = Event_vstore ch id ofs evv) - (WF0: wf_env e id) - (WF1: wf_eventval_env e evv) b argv m2 (SEM: volatile_store_sem ch ge cp (Vptr b ofs :: argv :: nil) m1 (ev :: nil) Vundef m2) : - external_call_event_match ef ev ge cp m1 e Vundef m2 + external_call_event_match_common ef ev ge cp m1 Vundef m2 | ext_match_annot len text targs (EF: ef = EF_annot len text targs) evargs (EV: ev = Event_annot text evargs) - (WFENV: Forall (wf_eventval_env e) evargs) vargs m2 (SEM: extcall_annot_sem text targs ge cp vargs m1 (ev :: nil) Vundef m2) : - external_call_event_match ef ev ge cp m1 e Vundef m2 + external_call_event_match_common ef ev ge cp m1 Vundef m2 | ext_match_external name excp sg (EF: ef = EF_external name excp sg) evname evargs evres (EV: ev = Event_syscall evname evargs evres) - (WFENV: Forall (wf_eventval_env e) evargs) vargs vres m2 (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) : - external_call_event_match ef ev ge cp m1 e vres m2 + external_call_event_match_common ef ev ge cp m1 vres m2 | ext_match_builtin name sg (EF: (ef = EF_builtin name sg) \/ (ef = EF_runtime name sg)) evname evargs evres (EV: ev = Event_syscall evname evargs evres) - (WFENV: Forall (wf_eventval_env e) evargs) (ISEXT: Builtins.lookup_builtin_function name sg = None) vargs vres m2 (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) : - external_call_event_match ef ev ge cp m1 e vres m2 + external_call_event_match_common ef ev ge cp m1 vres m2 | ext_match_inline_asm txt sg strs (EF: ef = EF_inline_asm txt sg strs) evname evargs evres (EV: ev = Event_syscall evname evargs evres) - (WFENV: Forall (wf_eventval_env e) evargs) vargs vres m2 (SEM: inline_assembly_sem txt sg ge cp vargs m1 (ev :: nil) vres m2) (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) : - external_call_event_match ef ev ge cp m1 e vres m2 + external_call_event_match_common ef ev ge cp m1 vres m2 . + Variant external_call_wf_env (ev: event) (e: env): Prop := + | ext_wf_env_vload + ch id ofs evv + (EV: ev = Event_vload ch id ofs evv) + (WF: wf_env e id) + : + external_call_wf_env ev e + | ext_wf_env_vstore + ch id ofs evv + (EV: ev = Event_vstore ch id ofs evv) + (WF0: wf_env e id) + (WF1: wf_eventval_env e evv) + : + external_call_wf_env ev e + | ext_wf_env_annot + text evargs + (EV: ev = Event_annot text evargs) + (WFENV: Forall (wf_eventval_env e) evargs) + : + external_call_wf_env ev e + | ext_wf_env_syscall + evname evargs evres + (EV: ev = Event_syscall evname evargs evres) + (WFENV: Forall (wf_eventval_env e) evargs) + : + external_call_wf_env ev e. + + Definition external_call_event_match (ef: external_function) (ev: event) (ge: Senv.t) (cp: compartment) (m1: mem) (e: env) : val -> mem -> Prop := + fun res m2 => + (external_call_event_match_common ef ev ge cp m1 res m2) /\ (external_call_wf_env ev e). + + (* Variant external_call_event_match (ef: external_function) (ev: event) (ge: Senv.t) (cp: compartment) (m1: mem) (e: env) : val -> mem -> Prop := *) + (* | ext_match_vload *) + (* ch *) + (* (EF: ef = EF_vload ch) *) + (* id ofs evv *) + (* (EV: ev = Event_vload ch id ofs evv) *) + (* (WF: wf_env e id) *) + (* b res m2 *) + (* (SEM: volatile_load_sem ch ge cp (Vptr b ofs :: nil) m1 (ev :: nil) res m2) *) + (* : *) + (* external_call_event_match ef ev ge cp m1 e res m2 *) + (* | ext_match_vstore *) + (* ch *) + (* (EF: ef = EF_vstore ch) *) + (* id ofs evv *) + (* (EV: ev = Event_vstore ch id ofs evv) *) + (* (WF0: wf_env e id) *) + (* (WF1: wf_eventval_env e evv) *) + (* b argv m2 *) + (* (SEM: volatile_store_sem ch ge cp (Vptr b ofs :: argv :: nil) m1 (ev :: nil) Vundef m2) *) + (* : *) + (* external_call_event_match ef ev ge cp m1 e Vundef m2 *) + (* | ext_match_annot *) + (* len text targs *) + (* (EF: ef = EF_annot len text targs) *) + (* evargs *) + (* (EV: ev = Event_annot text evargs) *) + (* (WFENV: Forall (wf_eventval_env e) evargs) *) + (* vargs m2 *) + (* (SEM: extcall_annot_sem text targs ge cp vargs m1 (ev :: nil) Vundef m2) *) + (* : *) + (* external_call_event_match ef ev ge cp m1 e Vundef m2 *) + (* | ext_match_external *) + (* name excp sg *) + (* (EF: ef = EF_external name excp sg) *) + (* evname evargs evres *) + (* (EV: ev = Event_syscall evname evargs evres) *) + (* (WFENV: Forall (wf_eventval_env e) evargs) *) + (* vargs vres m2 *) + (* (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) *) + (* (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) *) + (* : *) + (* external_call_event_match ef ev ge cp m1 e vres m2 *) + (* | ext_match_builtin *) + (* name sg *) + (* (EF: (ef = EF_builtin name sg) \/ (ef = EF_runtime name sg)) *) + (* evname evargs evres *) + (* (EV: ev = Event_syscall evname evargs evres) *) + (* (WFENV: Forall (wf_eventval_env e) evargs) *) + (* (ISEXT: Builtins.lookup_builtin_function name sg = None) *) + (* vargs vres m2 *) + (* (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) *) + (* (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) *) + (* : *) + (* external_call_event_match ef ev ge cp m1 e vres m2 *) + (* | ext_match_inline_asm *) + (* txt sg strs *) + (* (EF: ef = EF_inline_asm txt sg strs) *) + (* evname evargs evres *) + (* (EV: ev = Event_syscall evname evargs evres) *) + (* (WFENV: Forall (wf_eventval_env e) evargs) *) + (* vargs vres m2 *) + (* (SEM: inline_assembly_sem txt sg ge cp vargs m1 (ev :: nil) vres m2) *) + (* (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) *) + (* : *) + (* external_call_event_match ef ev ge cp m1 e vres m2 *) + (* . *) + (* Step lemmas *) Lemma code_of_event_step_intra_call_ext ev ik ef @@ -1042,14 +1136,17 @@ Section Backtranslation. (ev :: nil) (State f Sskip k e le m2). Proof. - inv EXT; subst; simpl in *. - - pose proof SEM as SEM0. inv SEM. inv H5. rewrite INV. econstructor 2. + destruct EXT as [EXT ENV]. inv EXT; subst; simpl in *. + - inv ENV; inv EV. + pose proof SEM as SEM0. inv SEM. inv H5. rewrite INV. econstructor 2. { eapply step_call. 4:{ instantiate (2:=Vptr fb Ptrofs.zero). unfold Genv.find_funct. rewrite pred_dec_true; eauto. } 4:{ simpl. eauto. } auto. { eapply eval_Elvalue. eapply eval_Evar_global; auto. eapply Genv.invert_find_symbol; eauto. simpl. econstructor 2. auto. } - { econstructor; eauto. 3: econstructor. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. eapply sem_cast_ptr. } + { econstructor; eauto. 3: econstructor. eapply ptr_of_id_ofs_eval; eauto. + rewrite ptr_of_id_ofs_typeof. eapply sem_cast_ptr. + } auto. { intros F. simpl in *. contradiction. } { econstructor 1. auto. } @@ -1063,14 +1160,17 @@ Section Backtranslation. - econstructor 1. auto. } simpl. econstructor 1. all: eauto. - - pose proof SEM as SEM0. inv SEM. inv H5. rewrite INV. econstructor 2. + - inv ENV; inv EV. + pose proof SEM as SEM0. inv SEM. inv H5. rewrite INV. econstructor 2. { eapply step_call. 4:{ instantiate (2:=Vptr fb Ptrofs.zero). unfold Genv.find_funct. rewrite pred_dec_true; eauto. } 4:{ simpl. eauto. } auto. { eapply eval_Elvalue. eapply eval_Evar_global; auto. eapply Genv.invert_find_symbol; eauto. simpl. econstructor 2. auto. } - { econstructor; eauto. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. eapply sem_cast_ptr. - econstructor; eauto. 3: econstructor. eapply eventval_to_expr_val_eval; auto. eapply eventval_match_wf_eventval_ge; eauto. + { econstructor; eauto. eapply ptr_of_id_ofs_eval; eauto. + rewrite ptr_of_id_ofs_typeof. eapply sem_cast_ptr. + econstructor; eauto. 3: econstructor. eapply eventval_to_expr_val_eval; auto. + eapply eventval_match_wf_eventval_ge; eauto. eapply eventval_match_sem_cast. erewrite eventval_match_eventval_to_val; eauto. } auto. @@ -1086,7 +1186,8 @@ Section Backtranslation. - econstructor 1. auto. } simpl. econstructor 1. all: eauto. - - pose proof SEM as SEM0. inv SEM. rewrite INV. econstructor 2. + - inv ENV; inv EV. + pose proof SEM as SEM0. inv SEM. rewrite INV. econstructor 2. { eapply step_call. 4:{ instantiate (2:=Vptr fb Ptrofs.zero). unfold Genv.find_funct. rewrite pred_dec_true; eauto. } 4:{ simpl. eauto. } @@ -1106,7 +1207,7 @@ Section Backtranslation. - econstructor 1. auto. } simpl. econstructor 1. all: eauto. - - rewrite INV. econstructor 2. + - inv ENV; inv EV. rewrite INV. econstructor 2. { eapply step_call. 4:{ instantiate (2:=Vptr fb Ptrofs.zero). unfold Genv.find_funct. rewrite pred_dec_true; eauto. } 4:{ simpl. eauto. } @@ -1126,7 +1227,7 @@ Section Backtranslation. - econstructor 1. auto. } simpl. econstructor 1. all: eauto. - - rewrite INV. econstructor 2. + - inv ENV; inv EV. rewrite INV. econstructor 2. { eapply step_call. 4:{ instantiate (2:=Vptr fb Ptrofs.zero). unfold Genv.find_funct. rewrite pred_dec_true; eauto. } 4:{ simpl. eauto. } @@ -1146,7 +1247,7 @@ Section Backtranslation. - econstructor 1. auto. } simpl. econstructor 1. all: eauto. - - rewrite INV. econstructor 2. + - inv ENV; inv EV. rewrite INV. econstructor 2. { eapply step_call. 4:{ instantiate (2:=Vptr fb Ptrofs.zero). unfold Genv.find_funct. rewrite pred_dec_true; eauto. } 4:{ simpl. eauto. } @@ -1183,13 +1284,13 @@ Section Backtranslation. (ev :: nil) (State f Sskip k e le m2). Proof. - inv EXT; subst; simpl in *. - - pose proof SEM as SEM0. inv SEM. inv H5. econstructor 2. + destruct EXT as [EXT ENV]. inv EXT; subst; simpl in *. + - inv ENV; inv EV. pose proof SEM as SEM0. inv SEM. inv H5. econstructor 2. { eapply step_builtin; eauto. econstructor; eauto. 3: econstructor. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. eapply sem_cast_ptr. } simpl. econstructor 1. all: eauto. - - pose proof SEM as SEM0. inv SEM. inv H5. econstructor 2. + - inv ENV; inv EV. pose proof SEM as SEM0. inv SEM. inv H5. econstructor 2. { apply val_load_result_aux in H10. eapply step_builtin. - econstructor; eauto. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. eapply sem_cast_ptr. @@ -1198,13 +1299,13 @@ Section Backtranslation. - simpl. econstructor. econstructor 1; eauto. } simpl. econstructor 1. all: eauto. - - pose proof SEM as SEM0. inv SEM. econstructor 2. + - inv ENV; inv EV. pose proof SEM as SEM0. inv SEM. econstructor 2. { eapply step_builtin; eauto. eapply list_eventval_to_expr_val_eval_typs; eauto. } simpl. econstructor 1. all: eauto. - - econstructor 2. + - inv ENV; inv EV. econstructor 2. { eapply step_builtin; eauto. eapply list_eventval_to_expr_val_eval_typs; eauto. } simpl. econstructor 1. all: eauto. - - econstructor 2. + - inv ENV; inv EV. econstructor 2. { destruct EF; subst; simpl. - eapply step_builtin. eapply list_eventval_to_expr_val_eval_typs; eauto. simpl. red. rewrite ISEXT. eauto. @@ -1212,7 +1313,7 @@ Section Backtranslation. simpl. red. rewrite ISEXT. eauto. } simpl. econstructor 1. all: eauto. - - econstructor 2. + - inv ENV; inv EV. econstructor 2. { eapply step_builtin; eauto. eapply list_eventval_to_expr_val_eval_typs; eauto. } simpl. econstructor 1. all: eauto. Qed. @@ -1361,34 +1462,272 @@ Section Backtranslation. all: eauto. Qed. - (* TODO *) End STEPPROP. Section WELLFORMED. - Definition empty_le := PTree.empty val. + Definition empty_te: temp_env := PTree.empty val. + + (* Variant sf_cont_type : Type := | sf_cont: block -> signature -> sf_cont_type. *) + Variant sf_cont_type : Type := | sf_cont: block -> sf_cont_type. + Definition sf_conts := list sf_cont_type. (* wf_sem: from asm, wf_st: proof invariant for Clight states *) - Definition wf_sem_vload {F V} (ge: Genv.t F V) (ch: memory_chunk) (id: ident) (ofs: ptrofs) (v: eventval) := - (exists b, (Genv.find_symbol ge id = Some b) /\ (Senv.block_is_volatile ge b = true)) /\ - (exists rv, (eventval_match ge v (type_of_chunk ch) rv)). + Inductive from_info_asm_wf (ge: Asm.genv) : block -> mem -> sf_conts -> itrace -> Prop := + | from_info_asm_wf_intra_call_external + cur m1 sf ev ik tl + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + ef res m2 + (EXTEV: external_call_event_match_common ef ev ge cp m1 res m2) + fb + (IK: ik = info_external fb (ef_sig ef)) + fid + (INV: Genv.invert_symbol ge fb = Some fid) + (ISEXT: Genv.find_funct_ptr ge fb = Some (AST.External ef)) + (ALLOWED: Genv.allowed_call ge cp (Vptr fb Ptrofs.zero)) + (INTRA: Genv.type_of_call ge cp (Genv.find_comp ge (Vptr fb Ptrofs.zero)) <> Genv.CrossCompartmentCall) + (NEXT: from_info_asm_wf ge cur m2 sf tl) + : + from_info_asm_wf ge cur m1 sf ((ev, ik) :: tl) + | from_info_asm_wf_builtin + cur m1 sf ev ik tl + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + ef res m2 + (EXT: external_call_event_match_common ef ev ge cp m1 res m2) + (IK: ik = info_builtin ef) + (NEXT: from_info_asm_wf ge cur m2 sf tl) + : + from_info_asm_wf ge cur m1 sf ((ev, ik) :: tl) + | from_info_asm_wf_cross_call_internal + cur m1 sf ev ik tl + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + cp' fid evargs + (EV: ev = Event_call cp cp' fid evargs) + sg + (IK: ik = info_call not_cross_ext sg) + b + (FINDB: Genv.find_symbol ge fid = Some b) + fd + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (CP': cp' = comp_of fd) + (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) + args + (NPTR: Forall not_ptr args) + (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) + (ESM: eventval_list_match ge evargs (sig_args sg) args) + callee_f + (INTERNAL: fd = AST.Internal callee_f) + (SIG: sg = Asm.fn_sig callee_f) + (* internal call: memory changes in Clight-side, so need inj-relation *) + (NEXT: from_info_asm_wf ge b m1 ((sf_cont cur) :: sf) tl) + : + from_info_asm_wf ge cur m1 sf ((ev, ik) :: tl) + | from_info_asm_wf_cross_return_internal + cur m1 sf ev ik tl + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + cp_c evres + (EV: ev = Event_return cp_c cp evres) + sg + (IK: ik = info_return sg) + cur_f + (INTERNAL: Genv.find_funct_ptr ge cur = Some (AST.Internal cur_f)) + (SIG: sg = Asm.fn_sig cur_f) + (CROSS: Genv.type_of_call ge cp_c cp = Genv.CrossCompartmentCall) + res + (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) res) + (NPTR: not_ptr res) + b_c sf_tl + (SF: sf = (sf_cont b_c) :: sf_tl) + (CPC: cp_c = Genv.find_comp ge (Vptr b_c Ptrofs.zero)) + (* internal return: memory changes in Clight-side, so need inj-relation *) + (NEXT: from_info_asm_wf ge b_c m1 sf_tl tl) + : + from_info_asm_wf ge cur m1 sf ((ev, ik) :: tl). + (* TODO: cross-ext cases *) + + + Lemma code_of_event_step_cross_call_start + ev ik + p f k e le m ge cp + (CP: cp = comp_of f) + (GE: ge = globalenv p) + cp' fid evargs + (EV: ev = Event_call cp cp' fid evargs) + ce sg + (IK: ik = info_call ce sg) + (WF0: wf_env e fid) + (WF1: Forall (wf_eventval_env e) evargs) + tdata + (TD: tdata = from_sig_fun_data sg) + args + (ARGS: args = list_eventval_to_list_val ge evargs) + b + (FINDB: Genv.find_symbol ge fid = Some b) + fd + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (TYPEF: type_of_fundef fd = Tfunction tdata.(dargs) tdata.(dret) tdata.(dcc)) + (CP': cp' = comp_of fd) + (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) + (NPTR: Forall not_ptr args) + (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) + (ESM: eventval_list_match ge evargs (sig_args sg) args) + : + Star (Clight.semantics1 p) + (State f (code_of_ievent ge (ev, ik)) k e le m) + (ev :: nil) + (Callstate fd args (Kcall None f e le k) m). + Proof. + Qed. + + Lemma code_of_event_step_cross_call_ext + ev ef + p k m ge cp vres m' + targs tres cconv vargs + (CP: cp = call_comp k) + (GE: ge = globalenv p) + (EXT: external_call ef ge cp vargs m (ev :: nil) vres m') + (* bt_wf *) + (* from_asm *) + : + Star (Clight.semantics1 p) + (Callstate (External ef targs tres cconv) vargs k m) + (ev :: nil) + (Returnstate vres k m' (rettype_of_type tres) (comp_of ef)). + Proof. + Qed. + + Lemma code_of_event_step_cross_returnstate + ev ik sg evres + p ge res optid f e le k m ty cp + (GE: ge = globalenv p) + (EV: ev = Event_return (comp_of f) cp evres) + (IK: ik = info_return sg) + (CROSS: Genv.type_of_call ge (comp_of f) cp = Genv.CrossCompartmentCall) + (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) res) + (NPTR: not_ptr res) + (RETTY: ty = sig_res sg) + : + Star (Clight.semantics1 p) + (Returnstate res (Kcall optid f e le k) m ty cp) + (ev :: nil) + (State f Sskip k e (set_opttemp optid res le) m). + Proof. + Qed. + + (* TODO *) + (* Step lemmas *) + Lemma code_of_event_step_cross_call_ext + ev ef + p k m ge cp vres m' + targs tres cconv vargs + (CP: cp = call_comp k) + (GE: ge = globalenv p) + (EXT: external_call ef ge cp vargs m (ev :: nil) vres m') + (* bt_wf *) + (* from_asm *) + : + Star (Clight.semantics1 p) + (Callstate (External ef targs tres cconv) vargs k m) + (ev :: nil) + (Returnstate vres k m' (rettype_of_type tres) (comp_of ef)). + Proof. + Qed. - Definition wf_st_vload (ch: memory_chunk) (id: ident) (ofs: ptrofs) (v: eventval) e := - (wf_env e id). + Lemma code_of_event_step_cross_call_start + ev ik + p f k e le m ge cp + (CP: cp = comp_of f) + (GE: ge = globalenv p) + cp' fid evargs + (EV: ev = Event_call cp cp' fid evargs) + ce sg + (IK: ik = info_call ce sg) + (WF0: wf_env e fid) + (WF1: Forall (wf_eventval_env e) evargs) + tdata + (TD: tdata = from_sig_fun_data sg) + args + (ARGS: args = list_eventval_to_list_val ge evargs) + b + (FINDB: Genv.find_symbol ge fid = Some b) + fd + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (TYPEF: type_of_fundef fd = Tfunction tdata.(dargs) tdata.(dret) tdata.(dcc)) + (CP': cp' = comp_of fd) + (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) + (NPTR: Forall not_ptr args) + (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) + (ESM: eventval_list_match ge evargs (sig_args sg) args) + : + Star (Clight.semantics1 p) + (State f (code_of_ievent ge (ev, ik)) k e le m) + (ev :: nil) + (Callstate fd args (Kcall None f e le k) m). + Proof. + Qed. - Definition wf_sem_vstore {F V} (ge: Genv.t F V) (ch: memory_chunk) (id: ident) (ofs: ptrofs) v := - (exists b, (Genv.find_symbol ge id = Some b) /\ (Senv.block_is_volatile ge b = true)) /\ - (exists vv, eventval_match ge v (type_of_chunk ch) (Val.load_result ch vv)). + Lemma code_of_event_step_cross_call_int + p f vargs k m1 m2 e le + (ENT: function_entry1 (globalenv p) f vargs m1 e le m2) + : + Star (Clight.semantics1 p) + (Callstate (Internal f) vargs k m1) + (nil) + (State f (fn_body f) k e le m2). + Proof. + Qed. - Definition wf_st_vstore (ch: memory_chunk) (id: ident) (ofs: ptrofs) v e := - (wf_env e id) /\ (wf_eventval_env e v). + Lemma code_of_event_step_cross_returnstate + ev ik sg evres + p ge res optid f e le k m ty cp + (GE: ge = globalenv p) + (EV: ev = Event_return (comp_of f) cp evres) + (IK: ik = info_return sg) + (CROSS: Genv.type_of_call ge (comp_of f) cp = Genv.CrossCompartmentCall) + (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) res) + (NPTR: not_ptr res) + (RETTY: ty = sig_res sg) + : + Star (Clight.semantics1 p) + (Returnstate res (Kcall optid f e le k) m ty cp) + (ev :: nil) + (State f Sskip k e (set_opttemp optid res le) m). + Proof. + Qed. - Definition wf_sem_annot {F V} (ge: Genv.t F V) (str: string) (vs: list eventval) := - exists targs vargs, eventval_list_match ge vs targs vargs. + Lemma code_of_event_step_cross_return_code + ev ik + p f k e le m ge cp + (CP: cp = comp_of f) + (GE: ge = globalenv p) + cp_c evres + (EV: ev = Event_return cp_c cp evres) + (WF: wf_eventval_env e evres) + sg + (IK: ik = info_return sg) + (CROSS: Genv.type_of_call ge cp_c cp = Genv.CrossCompartmentCall) + optid f_c e_c le_c k_c + (CONT: call_cont k = Kcall optid f_c e_c le_c k_c) + (CPC: cp_c = comp_of f_c) + res + (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) res) + (NPTR: not_ptr res) + (TY: fn_return f = rettype_to_type (sig_res sg)) + m' + (FREE: Mem.free_list m (blocks_of_env ge e) cp = Some m') + : + Star (Clight.semantics1 p) + (State f (code_of_ievent ge (ev, ik)) k e le m) + (ev :: nil) + (State f_c Sskip k_c e_c (set_opttemp optid res le_c) m'). + Proof. + Qed. - Definition wf_st_annot (str: string) (vs: list eventval) e := - (Forall (wf_eventval_env e) vs). Definition wf_sem_call_start_cl (ge: genv) (cp cp': compartment) (id: ident) (vs: list eventval) (fd: Clight.fundef) := exists b, From 494bc598810e29cf811e826221e411e2bcd77e65 Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 8 May 2023 21:01:35 +0200 Subject: [PATCH 044/174] WIP --- security/Backtranslation.v | 463 +++++++++---------------------------- 1 file changed, 104 insertions(+), 359 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index dc8998c398..6f035d1594 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1319,22 +1319,25 @@ Section Backtranslation. Qed. Lemma code_of_event_step_cross_call_ext - ev ef + (* ev ef *) + tr ef p k m ge cp vres m' targs tres cconv vargs (CP: cp = call_comp k) (GE: ge = globalenv p) - (EXT: external_call ef ge cp vargs m (ev :: nil) vres m') + (* (EXT: external_call ef ge cp vargs m (ev :: nil) vres m') *) + (EXT: external_call ef ge cp vargs m tr vres m') (* bt_wf *) (* from_asm *) : Star (Clight.semantics1 p) (Callstate (External ef targs tres cconv) vargs k m) - (ev :: nil) + (tr) + (* (ev :: nil) *) (Returnstate vres k m' (rettype_of_type tres) (comp_of ef)). Proof. subst; simpl in *. econstructor 2. eapply step_external_function. eauto. - econstructor 1. auto. + econstructor 1. traceEq. Qed. Lemma code_of_event_step_cross_call_start @@ -1521,13 +1524,18 @@ Section Backtranslation. (ESM: eventval_list_match ge evargs (sig_args sg) args) callee_f (INTERNAL: fd = AST.Internal callee_f) + (* TODO: separate this; + might be better to upgrade Asm semantics to actually refer to its fn_sig. + Note that it's not possible to recover Clight fun type data from trace since + there can be conflicts, since Asm semantics actually allows non-fixed sigs. + *) (SIG: sg = Asm.fn_sig callee_f) (* internal call: memory changes in Clight-side, so need inj-relation *) (NEXT: from_info_asm_wf ge b m1 ((sf_cont cur) :: sf) tl) : from_info_asm_wf ge cur m1 sf ((ev, ik) :: tl) | from_info_asm_wf_cross_return_internal - cur m1 sf ev ik tl + cur m1 ev ik tl cp (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) cp_c evres @@ -1536,379 +1544,116 @@ Section Backtranslation. (IK: ik = info_return sg) cur_f (INTERNAL: Genv.find_funct_ptr ge cur = Some (AST.Internal cur_f)) + (* TODO: separate this *) (SIG: sg = Asm.fn_sig cur_f) (CROSS: Genv.type_of_call ge cp_c cp = Genv.CrossCompartmentCall) res (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) res) (NPTR: not_ptr res) b_c sf_tl - (SF: sf = (sf_cont b_c) :: sf_tl) (CPC: cp_c = Genv.find_comp ge (Vptr b_c Ptrofs.zero)) (* internal return: memory changes in Clight-side, so need inj-relation *) (NEXT: from_info_asm_wf ge b_c m1 sf_tl tl) : - from_info_asm_wf ge cur m1 sf ((ev, ik) :: tl). - (* TODO: cross-ext cases *) - - - Lemma code_of_event_step_cross_call_start - ev ik - p f k e le m ge cp - (CP: cp = comp_of f) - (GE: ge = globalenv p) - cp' fid evargs - (EV: ev = Event_call cp cp' fid evargs) - ce sg - (IK: ik = info_call ce sg) - (WF0: wf_env e fid) - (WF1: Forall (wf_eventval_env e) evargs) - tdata - (TD: tdata = from_sig_fun_data sg) - args - (ARGS: args = list_eventval_to_list_val ge evargs) - b - (FINDB: Genv.find_symbol ge fid = Some b) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (TYPEF: type_of_fundef fd = Tfunction tdata.(dargs) tdata.(dret) tdata.(dcc)) - (CP': cp' = comp_of fd) - (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) - (NPTR: Forall not_ptr args) - (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) - (ESM: eventval_list_match ge evargs (sig_args sg) args) - : - Star (Clight.semantics1 p) - (State f (code_of_ievent ge (ev, ik)) k e le m) - (ev :: nil) - (Callstate fd args (Kcall None f e le k) m). - Proof. - Qed. - - Lemma code_of_event_step_cross_call_ext - ev ef - p k m ge cp vres m' - targs tres cconv vargs - (CP: cp = call_comp k) - (GE: ge = globalenv p) - (EXT: external_call ef ge cp vargs m (ev :: nil) vres m') - (* bt_wf *) - (* from_asm *) - : - Star (Clight.semantics1 p) - (Callstate (External ef targs tres cconv) vargs k m) - (ev :: nil) - (Returnstate vres k m' (rettype_of_type tres) (comp_of ef)). - Proof. - Qed. - - Lemma code_of_event_step_cross_returnstate - ev ik sg evres - p ge res optid f e le k m ty cp - (GE: ge = globalenv p) - (EV: ev = Event_return (comp_of f) cp evres) - (IK: ik = info_return sg) - (CROSS: Genv.type_of_call ge (comp_of f) cp = Genv.CrossCompartmentCall) - (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) res) - (NPTR: not_ptr res) - (RETTY: ty = sig_res sg) - : - Star (Clight.semantics1 p) - (Returnstate res (Kcall optid f e le k) m ty cp) - (ev :: nil) - (State f Sskip k e (set_opttemp optid res le) m). - Proof. - Qed. - - (* TODO *) - (* Step lemmas *) - Lemma code_of_event_step_cross_call_ext - ev ef - p k m ge cp vres m' - targs tres cconv vargs - (CP: cp = call_comp k) - (GE: ge = globalenv p) - (EXT: external_call ef ge cp vargs m (ev :: nil) vres m') - (* bt_wf *) - (* from_asm *) - : - Star (Clight.semantics1 p) - (Callstate (External ef targs tres cconv) vargs k m) - (ev :: nil) - (Returnstate vres k m' (rettype_of_type tres) (comp_of ef)). - Proof. - Qed. - - Lemma code_of_event_step_cross_call_start - ev ik - p f k e le m ge cp - (CP: cp = comp_of f) - (GE: ge = globalenv p) - cp' fid evargs - (EV: ev = Event_call cp cp' fid evargs) - ce sg - (IK: ik = info_call ce sg) - (WF0: wf_env e fid) - (WF1: Forall (wf_eventval_env e) evargs) - tdata - (TD: tdata = from_sig_fun_data sg) - args - (ARGS: args = list_eventval_to_list_val ge evargs) - b - (FINDB: Genv.find_symbol ge fid = Some b) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (TYPEF: type_of_fundef fd = Tfunction tdata.(dargs) tdata.(dret) tdata.(dcc)) - (CP': cp' = comp_of fd) - (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) - (NPTR: Forall not_ptr args) - (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) - (ESM: eventval_list_match ge evargs (sig_args sg) args) - : - Star (Clight.semantics1 p) - (State f (code_of_ievent ge (ev, ik)) k e le m) - (ev :: nil) - (Callstate fd args (Kcall None f e le k) m). - Proof. - Qed. - - Lemma code_of_event_step_cross_call_int - p f vargs k m1 m2 e le - (ENT: function_entry1 (globalenv p) f vargs m1 e le m2) - : - Star (Clight.semantics1 p) - (Callstate (Internal f) vargs k m1) - (nil) - (State f (fn_body f) k e le m2). - Proof. - Qed. - - Lemma code_of_event_step_cross_returnstate - ev ik sg evres - p ge res optid f e le k m ty cp - (GE: ge = globalenv p) - (EV: ev = Event_return (comp_of f) cp evres) - (IK: ik = info_return sg) - (CROSS: Genv.type_of_call ge (comp_of f) cp = Genv.CrossCompartmentCall) - (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) res) - (NPTR: not_ptr res) - (RETTY: ty = sig_res sg) - : - Star (Clight.semantics1 p) - (Returnstate res (Kcall optid f e le k) m ty cp) - (ev :: nil) - (State f Sskip k e (set_opttemp optid res le) m). - Proof. - Qed. - - Lemma code_of_event_step_cross_return_code - ev ik - p f k e le m ge cp - (CP: cp = comp_of f) - (GE: ge = globalenv p) - cp_c evres - (EV: ev = Event_return cp_c cp evres) - (WF: wf_eventval_env e evres) - sg - (IK: ik = info_return sg) - (CROSS: Genv.type_of_call ge cp_c cp = Genv.CrossCompartmentCall) - optid f_c e_c le_c k_c - (CONT: call_cont k = Kcall optid f_c e_c le_c k_c) - (CPC: cp_c = comp_of f_c) - res - (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) res) - (NPTR: not_ptr res) - (TY: fn_return f = rettype_to_type (sig_res sg)) - m' - (FREE: Mem.free_list m (blocks_of_env ge e) cp = Some m') - : - Star (Clight.semantics1 p) - (State f (code_of_ievent ge (ev, ik)) k e le m) - (ev :: nil) - (State f_c Sskip k_c e_c (set_opttemp optid res le_c) m'). - Proof. - Qed. - - - Definition wf_sem_call_start_cl (ge: genv) (cp cp': compartment) (id: ident) (vs: list eventval) (fd: Clight.fundef) := - exists b, - (Genv.find_symbol ge id = Some b) /\ - (Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) /\ - let data := from_clfd_fun_data fd in - (type_of_fundef fd = Tfunction data.(dargs) data.(dret) data.(dcc)) /\ - (cp' = comp_of fd) /\ - (Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) /\ - (Forall not_ptr (list_eventval_to_list_val ge vs)) /\ - (Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) /\ - exists some_sig_args some_vals, - (eventval_list_match ge vs some_sig_args some_vals) /\ - (data.(dargs) = (list_typ_to_typelist some_sig_args)). - - Definition wf_st_call_start (cp cp': compartment) (id: ident) (vs: list eventval) e (f: Clight.function) k k' := - (e ! id = None) /\ (Forall (wf_eventval_env e) vs) /\ (cp = comp_of f) /\ (k' = Kcall None f e empty_le k). - - Definition wf_st_call_internal (ge: genv) (vs: list eventval) (f1: Clight.function) m e1 m1 := - function_entry1 ge f1 (list_eventval_to_list_val ge vs) m e1 empty_le m1. - - Definition wf_sem_return {F V} (ge: Genv.t F V) (cp cp': compartment) (rv: eventval) := - (Genv.type_of_call ge cp' cp = Genv.CrossCompartmentCall) /\ - (not_ptr (eventval_to_val ge rv)) /\ - exists some_sig_ret some_val, - (eventval_match ge rv some_sig_ret some_val). - - Definition wf_st_return (ge: genv) (cp cp': compartment) (rv: eventval) e (f: Clight.function) (k: cont) (m: mem) f' k' e' m' := - (wf_eventval_env e rv) /\ - (cp = comp_of f) /\ - (forall some_sig_ret some_val, (eventval_match ge rv some_sig_ret some_val) -> (fn_return f = typ_to_type some_sig_ret)) /\ - (call_cont k = Kcall None f' e' empty_le k') /\ - (cp' = comp_of f') /\ - (Mem.free_list m (blocks_of_env ge e) (comp_of f) = Some m'). - - Definition wf_st_call_external_cross (ge: genv) (vs: list eventval) k m sname sargs svr ef m1 vres := - let sev := Event_syscall sname sargs svr in - (external_call ef ge (call_comp k) (list_eventval_to_list_val ge vs) m (sev :: nil) vres m1). - - Definition wf_st_return_external_cross (ge: genv) (cp_f' cp: compartment) vres (rv: eventval) ty (k: cont) f' k' e' := - (k = Kcall None f' e' empty_le k') /\ - (cp_f' = comp_of f') /\ - (Genv.type_of_call ge cp_f' cp = Genv.CrossCompartmentCall) /\ - (not_ptr vres) /\ (eventval_match ge rv (proj_rettype ty) vres). - - Definition wf_sem_call_external_intra (ge: genv) (name: string) (evargs: list eventval) (evres: eventval) (id: ident) (f: Clight.function) (fd: Clight.fundef) := - exists b, - (Genv.find_symbol ge id = Some b) /\ - (Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) /\ - let data := from_clfd_fun_data fd in - (type_of_fundef fd = Tfunction data.(dargs) data.(dret) data.(dcc)) /\ - let cp := comp_of f in - let cp' := comp_of fd in - (Genv.type_of_call ge cp cp' <> Genv.CrossCompartmentCall) /\ - (Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) /\ - exists some_sig_args some_vals, - (eventval_list_match ge evargs some_sig_args some_vals) /\ - (data.(dargs) = (list_typ_to_typelist some_sig_args)). - - Definition wf_st_call_external_intra (ge: genv) (name: string) (evargs: list eventval) (evres: eventval) (id: ident) (f: Clight.function) e := - (e ! id = None) /\ (Forall (wf_eventval_env e) evargs). - - Definition wf_sem_event_external_intra (ge: genv) (name: string) (evargs: list eventval) (evres: eventval) cp (ef: external_function) m m' := - exists name' cp' sg', - (* TODO: fix to incldue builtin, runtime, inline_asm *) - (ef = EF_external name' cp' sg') /\ - exists res, - (external_call ef ge cp (list_eventval_to_list_val ge evargs) m (Event_syscall name evargs evres :: nil) res m'). - - Lemma code_of_event_step_builtin - ev - name args rv - p f k e le m - ge - (GE: ge = globalenv p) - (EV: ev = Event_syscall name args rv) - name' sg - (ID: sid name = Some (sys_builtin name' sg)) - (* bt_wf *) - (WFARGS: Forall (wf_eventval_env e) args) - (* from_asm *) - (* invoke syscall *) - ef - (EF: ef = EF_builtin name' sg) - srv m' - (SEM: external_call ef ge (comp_of f) (list_eventval_to_list_val (globalenv p) args) m (ev :: nil) srv m') - (* conditions for argument types - might need extra semantics for EF_external *) - (* (TYARGS: data.(dargs) = (list_eventval_to_typelist args)) *) - some_sig_args some_vals - (ESM: eventval_list_match ge args some_sig_args some_vals) - (SIGARGS: sg.(sig_args) = (some_sig_args)) - : - Star (Clight.semantics1 p) - (State f (code_of_event sid (from_cl_funs_data p) ev) k e le m) - (ev :: nil) - (State f Sskip k e le m'). - - Inductive wf_inv_cl (ge: genv) (sid: string -> ident) : Clight.function -> cont -> env -> mem -> trace -> Prop := - | wf_inv_vload - f k e m t - ch id ofs v - (SEM: wf_sem_vload ge ch id ofs v) - (ST: wf_st_vload ch id ofs v e) - (IND: wf_inv_cl ge sid f k e m t) - : - wf_inv_cl ge sid f k e m (Event_vload ch id ofs v :: t) - | wf_inv_vstore - f k e m t - ch id ofs v - (SEM: wf_sem_vstore ge ch id ofs v) - (ST: wf_st_vstore ch id ofs v e) - (IND: wf_inv_cl ge sid f k e m t) - : - wf_inv_cl ge sid f k e m (Event_vstore ch id ofs v :: t) - | wf_inv_annot - f k e m t - str vs - (SEM: wf_sem_annot ge str vs) - (ST: wf_st_annot str vs e) - (IND: wf_inv_cl ge sid f k e m t) - : - wf_inv_cl ge sid f k e m (Event_annot str vs :: t) - - | wf_inv_call_internal - f k e m t - cp cp' id vs + from_info_asm_wf ge cur m1 ((sf_cont b_c) :: sf_tl) ((ev, ik) :: tl) + | from_info_asm_wf_cross_call_external1 + (* early cut at call event *) + cur m1 sf ev ik + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + cp' fid evargs + (EV: ev = Event_call cp cp' fid evargs) + sg + (IK: ik = info_call is_cross_ext sg) + b + (FINDB: Genv.find_symbol ge fid = Some b) fd - (SEM: wf_sem_call_start_cl ge cp cp' id vs fd) - k1 - (ST: wf_st_call_start cp cp' id vs e f k k1) - f1 e1 m1 - (ISINT: fd = Internal f1) - (INT: wf_st_call_internal ge vs f1 m e1 m1) - (IND: wf_inv_cl ge sid f1 k1 e1 m1 t) - : - wf_inv_cl ge sid f k e m (Event_call cp cp' id vs :: t) - | wf_inv_return - f k e m t - cp cp' rv - (SEM: wf_sem_return ge cp cp' rv) - f' k' e' m' - (ST: wf_st_return ge cp cp' rv e f k m f' k' e' m') - (IND: wf_inv_cl ge sid f' k' e' m' t) + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (CP': cp' = comp_of fd) + (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) + args + (NPTR: Forall not_ptr args) + (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) + (ESM: eventval_list_match ge evargs (sig_args sg) args) + ef + (EXTERNAL: fd = AST.External ef) + (* TODO: separate this *) + (SIG: sg = ef_sig ef) : - wf_inv_cl ge sid f k e m (Event_return cp cp' rv :: t) - - | wf_inv_external_cross - f k e m t - cp cp' id vs + from_info_asm_wf ge cur m1 sf ((ev, ik) :: nil) + | from_info_asm_wf_cross_call_external2 + (* early cut at call-ext_call event *) + cur m1 sf ev1 ik1 + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + cp' fid evargs + (EV: ev1 = Event_call cp cp' fid evargs) + sg + (IK: ik1 = info_call is_cross_ext sg) + b + (FINDB: Genv.find_symbol ge fid = Some b) fd - (SEM: wf_sem_call_start_cl ge cp cp' id vs fd) - k1 - (ST: wf_st_call_start cp cp' id vs e f k k1) - ef targs tres cconv - (ISEXT: fd = External ef targs tres cconv) - sname sargs svr m' vres - (EXT1: wf_st_call_external_cross ge vs k1 m sname sargs svr ef m' vres) - cp_f' cp_ef evres - f' k' e' - (EXT2: wf_st_return_external_cross ge cp_f' (comp_of ef) vres evres (rettype_of_type tres) k1 f' k' e') - (IND: wf_inv_cl ge sid f' k' e' m' t) + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (CP': cp' = comp_of fd) + (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) + args + (NPTR: Forall not_ptr args) + (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) + (ESM: eventval_list_match ge evargs (sig_args sg) args) + ef + (EXTERNAL: fd = AST.External ef) + (* TODO: separate this *) + (SIG: sg = ef_sig ef) + (* external call part *) + tr vres m2 + (EXTCALL: external_call ef ge cp args m1 tr vres m2) + itr + (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) : - wf_inv_cl ge sid f k e m ((Event_call cp cp' id vs) :: (Event_syscall sname sargs svr) :: (Event_return cp_f' cp_ef evres) :: t) - - | wf_inv_external_intra - f k e m t - name evargs evres + from_info_asm_wf ge cur m1 sf ((ev1, ik1) :: itr) + | from_info_asm_wf_cross_call_external3 + (* full call-ext_call-return event *) + cur m1 sf ev1 ik1 + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + cp' fid evargs + (EV: ev1 = Event_call cp cp' fid evargs) + sg + (IK: ik1 = info_call is_cross_ext sg) + b + (FINDB: Genv.find_symbol ge fid = Some b) fd - (SEM: wf_sem_call_external_intra ge name evargs evres (sid name) f fd) - (ST: wf_st_call_external_intra ge name evargs evres (sid name) f e) - ef targs tres cconv - (ISEXT: fd = External ef targs tres cconv) - m' - (EXT: wf_sem_event_external_intra ge name evargs evres (comp_of f) ef m m') - (IND: wf_inv_cl ge sid f k e m' t) + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (CP': cp' = comp_of fd) + (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) + args + (NPTR: Forall not_ptr args) + (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) + (ESM: eventval_list_match ge evargs (sig_args sg) args) + ef + (EXTERNAL: fd = AST.External ef) + (* TODO: separate this *) + (SIG: sg = ef_sig ef) + (* external call part *) + tr vres m2 + (EXTCALL: external_call ef ge cp args m1 tr vres m2) + itr + (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) + (* return part *) + ev3 ik3 tl + evres + (EV: ev3 = Event_return cp cp' evres) + sg + (IK: ik3 = info_return sg) + (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) vres) + (NPTR: not_ptr vres) + (NEXT: from_info_asm_wf ge cur m2 sf tl) : - wf_inv_cl ge sid f k e m (Event_syscall name evargs evres :: t) + from_info_asm_wf ge cur m1 sf ((ev1, ik1) :: (itr ++ ((ev3, ik3) :: tl))) . (* TODO *) - (* we need a more precise invariant for the proof, e.g. counters, mem_inj *) + (* we need a more precise invariant for the proof; counters, mem_inj, env, cont, state *) End WELLFORMED. From fa9267bbf4fdf686210ed3e6376774a477a162fa Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 9 May 2023 17:53:22 +0200 Subject: [PATCH 045/174] WIP: start proving from_asm_wf --- Makefile | 2 +- security/Backtranslation.v | 864 ++++++++++++++++++------------------- security/BtBasics.v | 254 +++++++++++ security/BtFromAsm.v | 309 +++++++++++++ 4 files changed, 996 insertions(+), 433 deletions(-) create mode 100644 security/BtBasics.v create mode 100644 security/BtFromAsm.v diff --git a/Makefile b/Makefile index 9a641a5f18..202188b049 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 BtInfoAsm.v Backtranslation.v +SECURITY=RSC.v Split.v Blame.v Recomposition.v BtInfoAsm.v BtBasics.v BtFromAsm.v Backtranslation.v # Parser diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 6f035d1594..fac1cda666 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -5,191 +5,191 @@ Require Import AST Linking Smallstep Events Behaviors. Require Import Split. Require Import riscV.Asm. -Require Import BtInfoAsm. +Require Import BtInfoAsm BtBasics BtFromAsm. Require Import Ctypes Clight. -Record syscall_properties (sem: extcall_sem) (sg: signature) : Prop := - mk_syscall_properties { - sc_args_match: - forall ge cp args m1 name evargs evres res m2, - sem ge cp args m1 (Event_syscall name evargs evres :: nil) res m2 -> - eventval_list_match ge evargs sg.(sig_args) args; - }. - - -Section GENV. - - Context {F: Type}. - Context {V: Type}. - - (* For NR, use below: *) - (* ::: mkpass Unusedglobproof.match_prog *) - (* match_prog_unique: *) - (* list_norepet (prog_defs_names tp) *) - 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.perm m1' b ofs Cur Writable -> *) - 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). - (* eapply Mem.perm_implies; eauto. constructor. *) - 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. - - (* Record unchanged_on (P : block -> Z -> Prop) (m_before m_after : mem) : Prop := mk_unchanged_on *) - (* { unchanged_on_nextblock : Ple (Mem.nextblock m_before) (Mem.nextblock m_after); *) - (* unchanged_on_perm : forall (b : block) (ofs : Z) (k : perm_kind) (p : permission), P b ofs -> Mem.valid_block m_before b -> Mem.perm m_before b ofs k p <-> Mem.perm m_after b ofs k p; *) - (* unchanged_on_contents : forall (b : block) (ofs : Z), P b ofs -> Mem.perm m_before b ofs Cur Readable -> ZMap.get ofs (Mem.mem_contents m_after) !! b = ZMap.get ofs (Mem.mem_contents m_before) !! b; *) - (* unchanged_on_own : forall (b : block) (cp : option compartment), Mem.valid_block m_before b -> Mem.can_access_block m_before b cp <-> Mem.can_access_block m_after b cp }. *) - - 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. - - (* -forall b, b is the block of one of the counter -> - (forall b0 ofs, ~ (f b0 = Some (b, ofs))) - *) - -(** Events.v **) -(* (** External calls must commute with memory injections, *) -(* in the following sense. *) *) -(* ec_mem_inject: *) -(* forall ge1 ge2 c vargs m1 t vres m2 f m1' vargs', *) -(* symbols_inject f ge1 ge2 -> *) -(* sem ge1 c vargs m1 t vres m2 -> *) -(* Mem.inject f m1 m1' -> *) -(* Val.inject_list f vargs vargs' -> *) -(* exists f', exists vres', exists m2', *) -(* sem ge2 c vargs' m1' t vres' m2' *) -(* /\ Val.inject f' vres vres' *) -(* /\ Mem.inject f' m2 m2' *) -(* /\ Mem.unchanged_on (loc_unmapped f) m1 m2 *) -(* /\ Mem.unchanged_on (loc_out_of_reach f m1) m1' m2' *) -(* /\ inject_incr f f' *) -(* /\ inject_separated f f' m1 m1'; *) - -End MEM. +(* Record syscall_properties (sem: extcall_sem) (sg: signature) : Prop := *) +(* mk_syscall_properties { *) +(* sc_args_match: *) +(* forall ge cp args m1 name evargs evres res m2, *) +(* sem ge cp args m1 (Event_syscall name evargs evres :: nil) res m2 -> *) +(* eventval_list_match ge evargs sg.(sig_args) args; *) +(* }. *) + + +(* Section GENV. *) + +(* Context {F: Type}. *) +(* Context {V: Type}. *) + +(* (* For NR, use below: *) *) +(* (* ::: mkpass Unusedglobproof.match_prog *) *) +(* (* match_prog_unique: *) *) +(* (* list_norepet (prog_defs_names tp) *) *) +(* 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.perm m1' b ofs Cur Writable -> *) *) +(* 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). *) +(* (* eapply Mem.perm_implies; eauto. constructor. *) *) +(* 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. *) + +(* (* Record unchanged_on (P : block -> Z -> Prop) (m_before m_after : mem) : Prop := mk_unchanged_on *) *) +(* (* { unchanged_on_nextblock : Ple (Mem.nextblock m_before) (Mem.nextblock m_after); *) *) +(* (* unchanged_on_perm : forall (b : block) (ofs : Z) (k : perm_kind) (p : permission), P b ofs -> Mem.valid_block m_before b -> Mem.perm m_before b ofs k p <-> Mem.perm m_after b ofs k p; *) *) +(* (* unchanged_on_contents : forall (b : block) (ofs : Z), P b ofs -> Mem.perm m_before b ofs Cur Readable -> ZMap.get ofs (Mem.mem_contents m_after) !! b = ZMap.get ofs (Mem.mem_contents m_before) !! b; *) *) +(* (* unchanged_on_own : forall (b : block) (cp : option compartment), Mem.valid_block m_before b -> Mem.can_access_block m_before b cp <-> Mem.can_access_block m_after b cp }. *) *) + +(* 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. *) + +(* (* *) +(* forall b, b is the block of one of the counter -> *) +(* (forall b0 ofs, ~ (f b0 = Some (b, ofs))) *) +(* *) *) + +(* (** Events.v **) *) +(* (* (** External calls must commute with memory injections, *) *) +(* (* in the following sense. *) *) *) +(* (* ec_mem_inject: *) *) +(* (* forall ge1 ge2 c vargs m1 t vres m2 f m1' vargs', *) *) +(* (* symbols_inject f ge1 ge2 -> *) *) +(* (* sem ge1 c vargs m1 t vres m2 -> *) *) +(* (* Mem.inject f m1 m1' -> *) *) +(* (* Val.inject_list f vargs vargs' -> *) *) +(* (* exists f', exists vres', exists m2', *) *) +(* (* sem ge2 c vargs' m1' t vres' m2' *) *) +(* (* /\ Val.inject f' vres vres' *) *) +(* (* /\ Mem.inject f' m2 m2' *) *) +(* (* /\ Mem.unchanged_on (loc_unmapped f) m1 m2 *) *) +(* (* /\ Mem.unchanged_on (loc_out_of_reach f m1) m1' m2' *) *) +(* (* /\ inject_incr f f' *) *) +(* (* /\ inject_separated f f' m1 m1'; *) *) + +(* End MEM. *) Section Backtranslation. @@ -950,68 +950,68 @@ Section Backtranslation. Section STEPPROP. - Variant external_call_event_match_common - (ef: external_function) (ev: event) (ge: Senv.t) (cp: compartment) (m1: mem) - : val -> mem -> Prop := - | ext_match_vload - ch - (EF: ef = EF_vload ch) - id ofs evv - (EV: ev = Event_vload ch id ofs evv) - b res m2 - (SEM: volatile_load_sem ch ge cp (Vptr b ofs :: nil) m1 (ev :: nil) res m2) - : - external_call_event_match_common ef ev ge cp m1 res m2 - | ext_match_vstore - ch - (EF: ef = EF_vstore ch) - id ofs evv - (EV: ev = Event_vstore ch id ofs evv) - b argv m2 - (SEM: volatile_store_sem ch ge cp (Vptr b ofs :: argv :: nil) m1 (ev :: nil) Vundef m2) - : - external_call_event_match_common ef ev ge cp m1 Vundef m2 - | ext_match_annot - len text targs - (EF: ef = EF_annot len text targs) - evargs - (EV: ev = Event_annot text evargs) - vargs m2 - (SEM: extcall_annot_sem text targs ge cp vargs m1 (ev :: nil) Vundef m2) - : - external_call_event_match_common ef ev ge cp m1 Vundef m2 - | ext_match_external - name excp sg - (EF: ef = EF_external name excp sg) - evname evargs evres - (EV: ev = Event_syscall evname evargs evres) - vargs vres m2 - (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) - (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) - : - external_call_event_match_common ef ev ge cp m1 vres m2 - | ext_match_builtin - name sg - (EF: (ef = EF_builtin name sg) \/ (ef = EF_runtime name sg)) - evname evargs evres - (EV: ev = Event_syscall evname evargs evres) - (ISEXT: Builtins.lookup_builtin_function name sg = None) - vargs vres m2 - (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) - (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) - : - external_call_event_match_common ef ev ge cp m1 vres m2 - | ext_match_inline_asm - txt sg strs - (EF: ef = EF_inline_asm txt sg strs) - evname evargs evres - (EV: ev = Event_syscall evname evargs evres) - vargs vres m2 - (SEM: inline_assembly_sem txt sg ge cp vargs m1 (ev :: nil) vres m2) - (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) - : - external_call_event_match_common ef ev ge cp m1 vres m2 - . + (* Variant external_call_event_match_common *) + (* (ef: external_function) (ev: event) (ge: Senv.t) (cp: compartment) (m1: mem) *) + (* : val -> mem -> Prop := *) + (* | ext_match_vload *) + (* ch *) + (* (EF: ef = EF_vload ch) *) + (* id ofs evv *) + (* (EV: ev = Event_vload ch id ofs evv) *) + (* b res m2 *) + (* (SEM: volatile_load_sem ch ge cp (Vptr b ofs :: nil) m1 (ev :: nil) res m2) *) + (* : *) + (* external_call_event_match_common ef ev ge cp m1 res m2 *) + (* | ext_match_vstore *) + (* ch *) + (* (EF: ef = EF_vstore ch) *) + (* id ofs evv *) + (* (EV: ev = Event_vstore ch id ofs evv) *) + (* b argv m2 *) + (* (SEM: volatile_store_sem ch ge cp (Vptr b ofs :: argv :: nil) m1 (ev :: nil) Vundef m2) *) + (* : *) + (* external_call_event_match_common ef ev ge cp m1 Vundef m2 *) + (* | ext_match_annot *) + (* len text targs *) + (* (EF: ef = EF_annot len text targs) *) + (* evargs *) + (* (EV: ev = Event_annot text evargs) *) + (* vargs m2 *) + (* (SEM: extcall_annot_sem text targs ge cp vargs m1 (ev :: nil) Vundef m2) *) + (* : *) + (* external_call_event_match_common ef ev ge cp m1 Vundef m2 *) + (* | ext_match_external *) + (* name excp sg *) + (* (EF: ef = EF_external name excp sg) *) + (* evname evargs evres *) + (* (EV: ev = Event_syscall evname evargs evres) *) + (* vargs vres m2 *) + (* (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) *) + (* (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) *) + (* : *) + (* external_call_event_match_common ef ev ge cp m1 vres m2 *) + (* | ext_match_builtin *) + (* name sg *) + (* (EF: (ef = EF_builtin name sg) \/ (ef = EF_runtime name sg)) *) + (* evname evargs evres *) + (* (EV: ev = Event_syscall evname evargs evres) *) + (* (ISEXT: Builtins.lookup_builtin_function name sg = None) *) + (* vargs vres m2 *) + (* (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) *) + (* (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) *) + (* : *) + (* external_call_event_match_common ef ev ge cp m1 vres m2 *) + (* | ext_match_inline_asm *) + (* txt sg strs *) + (* (EF: ef = EF_inline_asm txt sg strs) *) + (* evname evargs evres *) + (* (EV: ev = Event_syscall evname evargs evres) *) + (* vargs vres m2 *) + (* (SEM: inline_assembly_sem txt sg ge cp vargs m1 (ev :: nil) vres m2) *) + (* (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) *) + (* : *) + (* external_call_event_match_common ef ev ge cp m1 vres m2 *) + (* . *) Variant external_call_wf_env (ev: event) (e: env): Prop := | ext_wf_env_vload @@ -1468,194 +1468,194 @@ Section Backtranslation. End STEPPROP. - Section WELLFORMED. - - Definition empty_te: temp_env := PTree.empty val. - - (* Variant sf_cont_type : Type := | sf_cont: block -> signature -> sf_cont_type. *) - Variant sf_cont_type : Type := | sf_cont: block -> sf_cont_type. - Definition sf_conts := list sf_cont_type. - - (* wf_sem: from asm, wf_st: proof invariant for Clight states *) - Inductive from_info_asm_wf (ge: Asm.genv) : block -> mem -> sf_conts -> itrace -> Prop := - | from_info_asm_wf_intra_call_external - cur m1 sf ev ik tl - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - ef res m2 - (EXTEV: external_call_event_match_common ef ev ge cp m1 res m2) - fb - (IK: ik = info_external fb (ef_sig ef)) - fid - (INV: Genv.invert_symbol ge fb = Some fid) - (ISEXT: Genv.find_funct_ptr ge fb = Some (AST.External ef)) - (ALLOWED: Genv.allowed_call ge cp (Vptr fb Ptrofs.zero)) - (INTRA: Genv.type_of_call ge cp (Genv.find_comp ge (Vptr fb Ptrofs.zero)) <> Genv.CrossCompartmentCall) - (NEXT: from_info_asm_wf ge cur m2 sf tl) - : - from_info_asm_wf ge cur m1 sf ((ev, ik) :: tl) - | from_info_asm_wf_builtin - cur m1 sf ev ik tl - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - ef res m2 - (EXT: external_call_event_match_common ef ev ge cp m1 res m2) - (IK: ik = info_builtin ef) - (NEXT: from_info_asm_wf ge cur m2 sf tl) - : - from_info_asm_wf ge cur m1 sf ((ev, ik) :: tl) - | from_info_asm_wf_cross_call_internal - cur m1 sf ev ik tl - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - cp' fid evargs - (EV: ev = Event_call cp cp' fid evargs) - sg - (IK: ik = info_call not_cross_ext sg) - b - (FINDB: Genv.find_symbol ge fid = Some b) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (CP': cp' = comp_of fd) - (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) - args - (NPTR: Forall not_ptr args) - (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) - (ESM: eventval_list_match ge evargs (sig_args sg) args) - callee_f - (INTERNAL: fd = AST.Internal callee_f) - (* TODO: separate this; - might be better to upgrade Asm semantics to actually refer to its fn_sig. - Note that it's not possible to recover Clight fun type data from trace since - there can be conflicts, since Asm semantics actually allows non-fixed sigs. - *) - (SIG: sg = Asm.fn_sig callee_f) - (* internal call: memory changes in Clight-side, so need inj-relation *) - (NEXT: from_info_asm_wf ge b m1 ((sf_cont cur) :: sf) tl) - : - from_info_asm_wf ge cur m1 sf ((ev, ik) :: tl) - | from_info_asm_wf_cross_return_internal - cur m1 ev ik tl - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - cp_c evres - (EV: ev = Event_return cp_c cp evres) - sg - (IK: ik = info_return sg) - cur_f - (INTERNAL: Genv.find_funct_ptr ge cur = Some (AST.Internal cur_f)) - (* TODO: separate this *) - (SIG: sg = Asm.fn_sig cur_f) - (CROSS: Genv.type_of_call ge cp_c cp = Genv.CrossCompartmentCall) - res - (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) res) - (NPTR: not_ptr res) - b_c sf_tl - (CPC: cp_c = Genv.find_comp ge (Vptr b_c Ptrofs.zero)) - (* internal return: memory changes in Clight-side, so need inj-relation *) - (NEXT: from_info_asm_wf ge b_c m1 sf_tl tl) - : - from_info_asm_wf ge cur m1 ((sf_cont b_c) :: sf_tl) ((ev, ik) :: tl) - | from_info_asm_wf_cross_call_external1 - (* early cut at call event *) - cur m1 sf ev ik - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - cp' fid evargs - (EV: ev = Event_call cp cp' fid evargs) - sg - (IK: ik = info_call is_cross_ext sg) - b - (FINDB: Genv.find_symbol ge fid = Some b) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (CP': cp' = comp_of fd) - (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) - args - (NPTR: Forall not_ptr args) - (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) - (ESM: eventval_list_match ge evargs (sig_args sg) args) - ef - (EXTERNAL: fd = AST.External ef) - (* TODO: separate this *) - (SIG: sg = ef_sig ef) - : - from_info_asm_wf ge cur m1 sf ((ev, ik) :: nil) - | from_info_asm_wf_cross_call_external2 - (* early cut at call-ext_call event *) - cur m1 sf ev1 ik1 - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - cp' fid evargs - (EV: ev1 = Event_call cp cp' fid evargs) - sg - (IK: ik1 = info_call is_cross_ext sg) - b - (FINDB: Genv.find_symbol ge fid = Some b) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (CP': cp' = comp_of fd) - (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) - args - (NPTR: Forall not_ptr args) - (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) - (ESM: eventval_list_match ge evargs (sig_args sg) args) - ef - (EXTERNAL: fd = AST.External ef) - (* TODO: separate this *) - (SIG: sg = ef_sig ef) - (* external call part *) - tr vres m2 - (EXTCALL: external_call ef ge cp args m1 tr vres m2) - itr - (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) - : - from_info_asm_wf ge cur m1 sf ((ev1, ik1) :: itr) - | from_info_asm_wf_cross_call_external3 - (* full call-ext_call-return event *) - cur m1 sf ev1 ik1 - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - cp' fid evargs - (EV: ev1 = Event_call cp cp' fid evargs) - sg - (IK: ik1 = info_call is_cross_ext sg) - b - (FINDB: Genv.find_symbol ge fid = Some b) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (CP': cp' = comp_of fd) - (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) - args - (NPTR: Forall not_ptr args) - (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) - (ESM: eventval_list_match ge evargs (sig_args sg) args) - ef - (EXTERNAL: fd = AST.External ef) - (* TODO: separate this *) - (SIG: sg = ef_sig ef) - (* external call part *) - tr vres m2 - (EXTCALL: external_call ef ge cp args m1 tr vres m2) - itr - (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) - (* return part *) - ev3 ik3 tl - evres - (EV: ev3 = Event_return cp cp' evres) - sg - (IK: ik3 = info_return sg) - (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) vres) - (NPTR: not_ptr vres) - (NEXT: from_info_asm_wf ge cur m2 sf tl) - : - from_info_asm_wf ge cur m1 sf ((ev1, ik1) :: (itr ++ ((ev3, ik3) :: tl))) - . - - (* TODO *) - (* we need a more precise invariant for the proof; counters, mem_inj, env, cont, state *) - - End WELLFORMED. + (* Section WELLFORMED. *) + + (* Definition empty_te: temp_env := PTree.empty val. *) + + (* (* Variant sf_cont_type : Type := | sf_cont: block -> signature -> sf_cont_type. *) *) + (* Variant sf_cont_type : Type := | sf_cont: block -> sf_cont_type. *) + (* Definition sf_conts := list sf_cont_type. *) + + (* (* wf_sem: from asm, wf_st: proof invariant for Clight states *) *) + (* Inductive from_info_asm_wf (ge: Asm.genv) : block -> mem -> sf_conts -> itrace -> Prop := *) + (* | from_info_asm_wf_intra_call_external *) + (* cur m1 sf ev ik tl *) + (* cp *) + (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) + (* ef res m2 *) + (* (EXTEV: external_call_event_match_common ef ev ge cp m1 res m2) *) + (* fb *) + (* (IK: ik = info_external fb (ef_sig ef)) *) + (* fid *) + (* (INV: Genv.invert_symbol ge fb = Some fid) *) + (* (ISEXT: Genv.find_funct_ptr ge fb = Some (AST.External ef)) *) + (* (ALLOWED: Genv.allowed_call ge cp (Vptr fb Ptrofs.zero)) *) + (* (INTRA: Genv.type_of_call ge cp (Genv.find_comp ge (Vptr fb Ptrofs.zero)) <> Genv.CrossCompartmentCall) *) + (* (NEXT: from_info_asm_wf ge cur m2 sf tl) *) + (* : *) + (* from_info_asm_wf ge cur m1 sf ((ev, ik) :: tl) *) + (* | from_info_asm_wf_builtin *) + (* cur m1 sf ev ik tl *) + (* cp *) + (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) + (* ef res m2 *) + (* (EXT: external_call_event_match_common ef ev ge cp m1 res m2) *) + (* (IK: ik = info_builtin ef) *) + (* (NEXT: from_info_asm_wf ge cur m2 sf tl) *) + (* : *) + (* from_info_asm_wf ge cur m1 sf ((ev, ik) :: tl) *) + (* | from_info_asm_wf_cross_call_internal *) + (* cur m1 sf ev ik tl *) + (* cp *) + (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) + (* cp' fid evargs *) + (* (EV: ev = Event_call cp cp' fid evargs) *) + (* sg *) + (* (IK: ik = info_call not_cross_ext sg) *) + (* b *) + (* (FINDB: Genv.find_symbol ge fid = Some b) *) + (* fd *) + (* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) *) + (* (CP': cp' = comp_of fd) *) + (* (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) *) + (* args *) + (* (NPTR: Forall not_ptr args) *) + (* (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) *) + (* (ESM: eventval_list_match ge evargs (sig_args sg) args) *) + (* callee_f *) + (* (INTERNAL: fd = AST.Internal callee_f) *) + (* (* TODO: separate this; *) + (* might be better to upgrade Asm semantics to actually refer to its fn_sig. *) + (* Note that it's not possible to recover Clight fun type data from trace since *) + (* there can be conflicts, since Asm semantics actually allows non-fixed sigs. *) + (* *) *) + (* (SIG: sg = Asm.fn_sig callee_f) *) + (* (* internal call: memory changes in Clight-side, so need inj-relation *) *) + (* (NEXT: from_info_asm_wf ge b m1 ((sf_cont cur) :: sf) tl) *) + (* : *) + (* from_info_asm_wf ge cur m1 sf ((ev, ik) :: tl) *) + (* | from_info_asm_wf_cross_return_internal *) + (* cur m1 ev ik tl *) + (* cp *) + (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) + (* cp_c evres *) + (* (EV: ev = Event_return cp_c cp evres) *) + (* sg *) + (* (IK: ik = info_return sg) *) + (* cur_f *) + (* (INTERNAL: Genv.find_funct_ptr ge cur = Some (AST.Internal cur_f)) *) + (* (* TODO: separate this *) *) + (* (SIG: sg = Asm.fn_sig cur_f) *) + (* (CROSS: Genv.type_of_call ge cp_c cp = Genv.CrossCompartmentCall) *) + (* res *) + (* (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) res) *) + (* (NPTR: not_ptr res) *) + (* b_c sf_tl *) + (* (CPC: cp_c = Genv.find_comp ge (Vptr b_c Ptrofs.zero)) *) + (* (* internal return: memory changes in Clight-side, so need inj-relation *) *) + (* (NEXT: from_info_asm_wf ge b_c m1 sf_tl tl) *) + (* : *) + (* from_info_asm_wf ge cur m1 ((sf_cont b_c) :: sf_tl) ((ev, ik) :: tl) *) + (* | from_info_asm_wf_cross_call_external1 *) + (* (* early cut at call event *) *) + (* cur m1 sf ev ik *) + (* cp *) + (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) + (* cp' fid evargs *) + (* (EV: ev = Event_call cp cp' fid evargs) *) + (* sg *) + (* (IK: ik = info_call is_cross_ext sg) *) + (* b *) + (* (FINDB: Genv.find_symbol ge fid = Some b) *) + (* fd *) + (* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) *) + (* (CP': cp' = comp_of fd) *) + (* (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) *) + (* args *) + (* (NPTR: Forall not_ptr args) *) + (* (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) *) + (* (ESM: eventval_list_match ge evargs (sig_args sg) args) *) + (* ef *) + (* (EXTERNAL: fd = AST.External ef) *) + (* (* TODO: separate this *) *) + (* (SIG: sg = ef_sig ef) *) + (* : *) + (* from_info_asm_wf ge cur m1 sf ((ev, ik) :: nil) *) + (* | from_info_asm_wf_cross_call_external2 *) + (* (* early cut at call-ext_call event *) *) + (* cur m1 sf ev1 ik1 *) + (* cp *) + (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) + (* cp' fid evargs *) + (* (EV: ev1 = Event_call cp cp' fid evargs) *) + (* sg *) + (* (IK: ik1 = info_call is_cross_ext sg) *) + (* b *) + (* (FINDB: Genv.find_symbol ge fid = Some b) *) + (* fd *) + (* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) *) + (* (CP': cp' = comp_of fd) *) + (* (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) *) + (* args *) + (* (NPTR: Forall not_ptr args) *) + (* (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) *) + (* (ESM: eventval_list_match ge evargs (sig_args sg) args) *) + (* ef *) + (* (EXTERNAL: fd = AST.External ef) *) + (* (* TODO: separate this *) *) + (* (SIG: sg = ef_sig ef) *) + (* (* external call part *) *) + (* tr vres m2 *) + (* (EXTCALL: external_call ef ge cp args m1 tr vres m2) *) + (* itr *) + (* (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) *) + (* : *) + (* from_info_asm_wf ge cur m1 sf ((ev1, ik1) :: itr) *) + (* | from_info_asm_wf_cross_call_external3 *) + (* (* full call-ext_call-return event *) *) + (* cur m1 sf ev1 ik1 *) + (* cp *) + (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) + (* cp' fid evargs *) + (* (EV: ev1 = Event_call cp cp' fid evargs) *) + (* sg *) + (* (IK: ik1 = info_call is_cross_ext sg) *) + (* b *) + (* (FINDB: Genv.find_symbol ge fid = Some b) *) + (* fd *) + (* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) *) + (* (CP': cp' = comp_of fd) *) + (* (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) *) + (* args *) + (* (NPTR: Forall not_ptr args) *) + (* (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) *) + (* (ESM: eventval_list_match ge evargs (sig_args sg) args) *) + (* ef *) + (* (EXTERNAL: fd = AST.External ef) *) + (* (* TODO: separate this *) *) + (* (SIG: sg = ef_sig ef) *) + (* (* external call part *) *) + (* tr vres m2 *) + (* (EXTCALL: external_call ef ge cp args m1 tr vres m2) *) + (* itr *) + (* (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) *) + (* (* return part *) *) + (* ev3 ik3 tl *) + (* evres *) + (* (EV: ev3 = Event_return cp cp' evres) *) + (* sg *) + (* (IK: ik3 = info_return sg) *) + (* (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) vres) *) + (* (NPTR: not_ptr vres) *) + (* (NEXT: from_info_asm_wf ge cur m2 sf tl) *) + (* : *) + (* from_info_asm_wf ge cur m1 sf ((ev1, ik1) :: (itr ++ ((ev3, ik3) :: tl))) *) + (* . *) + + (* (* TODO *) *) + (* (* we need a more precise invariant for the proof; counters, mem_inj, env, cont, state *) *) + + (* End WELLFORMED. *) Section PROJ. diff --git a/security/BtBasics.v b/security/BtBasics.v new file mode 100644 index 0000000000..2e46fe73eb --- /dev/null +++ b/security/BtBasics.v @@ -0,0 +1,254 @@ +Require Import String. +Require Import Coqlib Maps Errors Integers Values Memory Globalenvs. +Require Import AST Linking Smallstep Events Behaviors. + +Require Import Split. + +Record syscall_properties (sem: extcall_sem) (sg: signature) : Prop := + mk_syscall_properties { + sc_args_match: + forall ge cp args m1 name evargs evres res m2, + sem ge cp args m1 (Event_syscall name evargs evres :: nil) res m2 -> + eventval_list_match ge evargs sg.(sig_args) args; + }. + + +Section GENV. + + Context {F: Type}. + Context {V: Type}. + + (* For NR, use below: *) + (* ::: mkpass Unusedglobproof.match_prog *) + (* match_prog_unique: *) + (* list_norepet (prog_defs_names tp) *) + 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.perm m1' b ofs Cur Writable -> *) + 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). + (* eapply Mem.perm_implies; eauto. constructor. *) + 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. + + (* Record unchanged_on (P : block -> Z -> Prop) (m_before m_after : mem) : Prop := mk_unchanged_on *) + (* { unchanged_on_nextblock : Ple (Mem.nextblock m_before) (Mem.nextblock m_after); *) + (* unchanged_on_perm : forall (b : block) (ofs : Z) (k : perm_kind) (p : permission), P b ofs -> Mem.valid_block m_before b -> Mem.perm m_before b ofs k p <-> Mem.perm m_after b ofs k p; *) + (* unchanged_on_contents : forall (b : block) (ofs : Z), P b ofs -> Mem.perm m_before b ofs Cur Readable -> ZMap.get ofs (Mem.mem_contents m_after) !! b = ZMap.get ofs (Mem.mem_contents m_before) !! b; *) + (* unchanged_on_own : forall (b : block) (cp : option compartment), Mem.valid_block m_before b -> Mem.can_access_block m_before b cp <-> Mem.can_access_block m_after b cp }. *) + + 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. + +(* +forall b, b is the block of one of the counter -> + (forall b0 ofs, ~ (f b0 = Some (b, ofs))) + *) + + (** Events.v **) +(* (** External calls must commute with memory injections, *) + (* in the following sense. *) *) + (* ec_mem_inject: *) + (* forall ge1 ge2 c vargs m1 t vres m2 f m1' vargs', *) + (* symbols_inject f ge1 ge2 -> *) + (* sem ge1 c vargs m1 t vres m2 -> *) + (* Mem.inject f m1 m1' -> *) + (* Val.inject_list f vargs vargs' -> *) + (* exists f', exists vres', exists m2', *) + (* sem ge2 c vargs' m1' t vres' m2' *) + (* /\ Val.inject f' vres vres' *) + (* /\ Mem.inject f' m2 m2' *) + (* /\ Mem.unchanged_on (loc_unmapped f) m1 m2 *) + (* /\ Mem.unchanged_on (loc_out_of_reach f m1) m1' m2' *) + (* /\ inject_incr f f' *) + (* /\ inject_separated f f' m1 m1'; *) + +End MEM. + +Section EXTCALL. + + Variant external_call_event_match_common + (ef: external_function) (ev: event) (ge: Senv.t) (cp: compartment) (m1: mem) + : val -> mem -> Prop := + | ext_match_vload + ch + (EF: ef = EF_vload ch) + id ofs evv + (EV: ev = Event_vload ch id ofs evv) + b res m2 + (SEM: volatile_load_sem ch ge cp (Vptr b ofs :: nil) m1 (ev :: nil) res m2) + : + external_call_event_match_common ef ev ge cp m1 res m2 + | ext_match_vstore + ch + (EF: ef = EF_vstore ch) + id ofs evv + (EV: ev = Event_vstore ch id ofs evv) + b argv m2 + (SEM: volatile_store_sem ch ge cp (Vptr b ofs :: argv :: nil) m1 (ev :: nil) Vundef m2) + : + external_call_event_match_common ef ev ge cp m1 Vundef m2 + | ext_match_annot + len text targs + (EF: ef = EF_annot len text targs) + evargs + (EV: ev = Event_annot text evargs) + vargs m2 + (SEM: extcall_annot_sem text targs ge cp vargs m1 (ev :: nil) Vundef m2) + : + external_call_event_match_common ef ev ge cp m1 Vundef m2 + | ext_match_external + name excp sg + (EF: ef = EF_external name excp sg) + evname evargs evres + (EV: ev = Event_syscall evname evargs evres) + vargs vres m2 + (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) + (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) + : + external_call_event_match_common ef ev ge cp m1 vres m2 + | ext_match_builtin + name sg + (EF: (ef = EF_builtin name sg) \/ (ef = EF_runtime name sg)) + evname evargs evres + (EV: ev = Event_syscall evname evargs evres) + (ISEXT: Builtins.lookup_builtin_function name sg = None) + vargs vres m2 + (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) + (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) + : + external_call_event_match_common ef ev ge cp m1 vres m2 + | ext_match_inline_asm + txt sg strs + (EF: ef = EF_inline_asm txt sg strs) + evname evargs evres + (EV: ev = Event_syscall evname evargs evres) + vargs vres m2 + (SEM: inline_assembly_sem txt sg ge cp vargs m1 (ev :: nil) vres m2) + (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) + : + external_call_event_match_common ef ev ge cp m1 vres m2 + . + +End EXTCALL. diff --git a/security/BtFromAsm.v b/security/BtFromAsm.v new file mode 100644 index 0000000000..ba0c0e1a97 --- /dev/null +++ b/security/BtFromAsm.v @@ -0,0 +1,309 @@ +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.Asm. +Require Import BtInfoAsm BtBasics. + + +Section WELLFORMED. + + (* Variant sf_cont_type : Type := | sf_cont: block -> signature -> sf_cont_type. *) + Variant sf_cont_type : Type := | sf_cont: block -> sf_cont_type. + Definition sf_conts := list sf_cont_type. + + (* wf_sem: from asm, wf_st: proof invariant for Clight states *) + Inductive info_asm_sem_wf (ge: Asm.genv) : block -> mem -> sf_conts -> itrace -> Prop := + | info_asm_sem_wf_base + cur m1 sf + : + info_asm_sem_wf ge cur m1 sf nil + | info_asm_sem_wf_intra_call_external + cur m1 sf ev ik tl + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + ef res m2 + (EXTEV: external_call_event_match_common ef ev ge cp m1 res m2) + fb + (IK: ik = info_external fb (ef_sig ef)) + fid + (INV: Genv.invert_symbol ge fb = Some fid) + (ISEXT: Genv.find_funct_ptr ge fb = Some (AST.External ef)) + (ALLOWED: Genv.allowed_call ge cp (Vptr fb Ptrofs.zero)) + (INTRA: Genv.type_of_call ge cp (Genv.find_comp ge (Vptr fb Ptrofs.zero)) <> Genv.CrossCompartmentCall) + (NEXT: info_asm_sem_wf ge cur m2 sf tl) + : + info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) + | info_asm_sem_wf_builtin + cur m1 sf ev ik tl + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + ef res m2 + (EXT: external_call_event_match_common ef ev ge cp m1 res m2) + (IK: ik = info_builtin ef) + (NEXT: info_asm_sem_wf ge cur m2 sf tl) + : + info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) + | info_asm_sem_wf_cross_call_internal + cur m1 sf ev ik tl + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + cp' fid evargs + (EV: ev = Event_call cp cp' fid evargs) + sg + (IK: ik = info_call not_cross_ext sg) + b + (FINDB: Genv.find_symbol ge fid = Some b) + fd + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (CP': cp' = comp_of fd) + (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) + args + (NPTR: Forall not_ptr args) + (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) + (ESM: eventval_list_match ge evargs (sig_args sg) args) + callee_f + (INTERNAL: fd = AST.Internal callee_f) + (* TODO: separate this; + might be better to upgrade Asm semantics to actually refer to its fn_sig. + Note that it's not possible to recover Clight fun type data from trace since + there can be conflicts, since Asm semantics actually allows non-fixed sigs. + *) + (SIG: sg = Asm.fn_sig callee_f) + (* internal call: memory changes in Clight-side, so need inj-relation *) + (NEXT: info_asm_sem_wf ge b m1 ((sf_cont cur) :: sf) tl) + : + info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) + | info_asm_sem_wf_cross_return_internal + cur m1 ev ik tl + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + cp_c evres + (EV: ev = Event_return cp_c cp evres) + sg + (IK: ik = info_return sg) + cur_f + (INTERNAL: Genv.find_funct_ptr ge cur = Some (AST.Internal cur_f)) + (* TODO: separate this *) + (SIG: sg = Asm.fn_sig cur_f) + (CROSS: Genv.type_of_call ge cp_c cp = Genv.CrossCompartmentCall) + res + (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) res) + (NPTR: not_ptr res) + b_c sf_tl + (CPC: cp_c = Genv.find_comp ge (Vptr b_c Ptrofs.zero)) + (* internal return: memory changes in Clight-side, so need inj-relation *) + (NEXT: info_asm_sem_wf ge b_c m1 sf_tl tl) + : + info_asm_sem_wf ge cur m1 ((sf_cont b_c) :: sf_tl) ((ev, ik) :: tl) + | info_asm_sem_wf_cross_call_external1 + (* early cut at call event *) + cur m1 sf ev ik + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + cp' fid evargs + (EV: ev = Event_call cp cp' fid evargs) + sg + (IK: ik = info_call is_cross_ext sg) + b + (FINDB: Genv.find_symbol ge fid = Some b) + fd + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (CP': cp' = comp_of fd) + (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) + args + (NPTR: Forall not_ptr args) + (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) + (ESM: eventval_list_match ge evargs (sig_args sg) args) + ef + (EXTERNAL: fd = AST.External ef) + (* TODO: separate this *) + (SIG: sg = ef_sig ef) + : + info_asm_sem_wf ge cur m1 sf ((ev, ik) :: nil) + | info_asm_sem_wf_cross_call_external2 + (* early cut at call-ext_call event *) + cur m1 sf ev1 ik1 + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + cp' fid evargs + (EV: ev1 = Event_call cp cp' fid evargs) + sg + (IK: ik1 = info_call is_cross_ext sg) + b + (FINDB: Genv.find_symbol ge fid = Some b) + fd + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (CP': cp' = comp_of fd) + (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) + args + (NPTR: Forall not_ptr args) + (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) + (ESM: eventval_list_match ge evargs (sig_args sg) args) + ef + (EXTERNAL: fd = AST.External ef) + (* TODO: separate this *) + (SIG: sg = ef_sig ef) + (* external call part *) + tr vres m2 + (EXTCALL: external_call ef ge cp args m1 tr vres m2) + itr + (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) + : + info_asm_sem_wf ge cur m1 sf ((ev1, ik1) :: itr) + | info_asm_sem_wf_cross_call_external3 + (* full call-ext_call-return event *) + cur m1 sf ev1 ik1 + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + cp' fid evargs + (EV: ev1 = Event_call cp cp' fid evargs) + sg + (IK: ik1 = info_call is_cross_ext sg) + b + (FINDB: Genv.find_symbol ge fid = Some b) + fd + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (CP': cp' = comp_of fd) + (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) + args + (NPTR: Forall not_ptr args) + (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) + (ESM: eventval_list_match ge evargs (sig_args sg) args) + ef + (EXTERNAL: fd = AST.External ef) + (* TODO: separate this *) + (SIG: sg = ef_sig ef) + (* external call part *) + tr vres m2 + (EXTCALL: external_call ef ge cp args m1 tr vres m2) + itr + (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) + (* return part *) + ev3 ik3 tl + evres + (EV: ev3 = Event_return cp cp' evres) + sg + (IK: ik3 = info_return sg) + (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) vres) + (NPTR: not_ptr vres) + (NEXT: info_asm_sem_wf ge cur m2 sf tl) + : + info_asm_sem_wf ge cur m1 sf ((ev1, ik1) :: (itr ++ ((ev3, ik3) :: tl))) + . + + (* TODO *) + (* we need a more precise invariant for the proof; counters, mem_inj, env, cont, state *) + +End WELLFORMED. + +Section MATCH. + + Variant match_stack_type : (sf_cont_type) -> (stackframe) -> Prop := + | match_stack_type_intro + b cp sg v ofs + : + match_stack_type (sf_cont b) (Stackframe b cp sg v ofs). + + Definition match_stack (sf: sf_conts) (st: stack) := Forall2 match_stack_type sf st. + + Definition match_block (ge: Asm.genv) (cur: block) (b: block) : Prop := + Genv.find_comp ge (Vptr cur Ptrofs.zero) = Genv.find_comp ge (Vptr b Ptrofs.zero). + + Definition meminj_ge {F V} (ge: Genv.t F V): meminj := + fun b => match Genv.invert_symbol ge b with + | Some id => match Genv.find_symbol ge id with + | Some b' => Some (b', 0) + | None => None + end + | None => None + end. + + Definition match_mem (ge: Asm.genv) (m_ir m_asm: mem): Prop := Mem.inject (meminj_ge ge) m_asm m_ir. + +(* Definition external_call_mem_inject_gen ef := ec_mem_inject (external_call_spec ef). *) + +(* external_call_mem_inject: *) +(* forall (ef : external_function) [F V : Type] [ge : Genv.t F V] (c : compartment) [vargs : list val] [m1 : mem] (t : trace) (vres : val) (m2 : mem) [f : block -> option (block * Z)] *) +(* [m1' : mem] [vargs' : list val], *) +(* meminj_preserves_globals ge f -> *) +(* external_call ef ge c vargs m1 t vres m2 -> *) +(* Mem.inject f m1 m1' -> *) +(* Val.inject_list f vargs vargs' -> *) +(* exists (f' : meminj) (vres' : val) (m2' : mem), *) +(* external_call ef ge c vargs' m1' t vres' m2' /\ *) +(* Val.inject f' vres vres' /\ Mem.inject f' m2 m2' /\ Mem.unchanged_on (loc_unmapped f) m1 m2 /\ Mem.unchanged_on (loc_out_of_reach f m1) m1' m2' /\ inject_incr f f' /\ inject_separated f f' m1 m1' *) + +(* meminj_preserves_globals: forall [F V : Type], Genv.t F V -> (block -> option (block * Z)) -> Prop *) +(* Separation.globalenv_preserved: forall {F V : Type}, Genv.t F V -> meminj -> block -> Prop *) +(* Genv.same_symbols: forall [F V : Type], meminj -> Genv.t F V -> Prop *) +(* Genv.init_mem p = Some m0 -> *) +(* Variable f: block -> option (block * Z). *) +(* Variable ge1 ge2: Senv.t. *) + +(* Definition symbols_inject : Prop := *) +(* (forall id, Senv.public_symbol ge2 id = Senv.public_symbol ge1 id) *) +(* /\ (forall id b1 b2 delta, *) +(* f b1 = Some(b2, delta) -> Senv.find_symbol ge1 id = Some b1 -> *) +(* delta = 0 /\ Senv.find_symbol ge2 id = Some b2) *) +(* /\ (forall id b1, *) +(* Senv.public_symbol ge1 id = true -> Senv.find_symbol ge1 id = Some b1 -> *) +(* exists b2, f b1 = Some(b2, 0) /\ Senv.find_symbol ge2 id = Some b2) *) +(* /\ (forall b1 b2 delta, *) +(* f b1 = Some(b2, delta) -> *) +(* Senv.block_is_volatile ge2 b2 = Senv.block_is_volatile ge1 b1). *) +(* Senv.equiv = *) +(* fun se1 se2 : Senv.t => *) +(* (forall id : ident, Senv.find_symbol se2 id = Senv.find_symbol se1 id) /\ *) +(* (forall id : ident, Senv.public_symbol se2 id = Senv.public_symbol se1 id) /\ (forall b : block, Senv.block_is_volatile se2 b = Senv.block_is_volatile se1 b) *) +(* : Senv.t -> Senv.t -> Prop *) + +End MATCH. + +Section PROOF. + + (* If main is External, treat it in a different case - the trace can start with Event_syscall, without a preceding Event_call *) + Lemma from_info_asm_sem_wf + ge cp s s' it + (STAR: istar (asm_istep cp) ge s it s') + st rs m + (STATE: s = State st rs m) + b ofs f + (RSPC: rs PC = Vptr b ofs) + (INT: Genv.find_funct_ptr ge b = Some (Internal f)) + cur m_ir k + (MATCHB: match_block ge cur b) + (MATCHM: match_mem ge m_ir m) + (MATCHS: match_stack k st) + : + info_asm_sem_wf ge cur m_ir k it. + Proof. + + + (* TODO *) + + Inductive info_asm_sem_wf (ge: Asm.genv) : block -> mem -> sf_conts -> itrace -> Prop := + Definition state_has_trace_informative (L: Smallstep.semantics) (s: state L) (step: istep L) (t: itrace): Prop := + (exists s', (istar step (globalenv L)) s t s'). + Variant semantics_has_initial_trace_informative (L: Smallstep.semantics) (step: istep L) (t: itrace) : Prop := + | semantics_info_runs : + forall s, (initial_state L s) -> (state_has_trace_informative L s step t) -> semantics_has_initial_trace_informative _ _ t + | semantics_info_goes_initially_wrong : (forall s : state L, ~ initial_state L s) -> (t = nil) -> semantics_has_initial_trace_informative _ _ t. + Definition asm_has_initial_trace_informative (p: Asm.program) (t: itrace) := + semantics_has_initial_trace_informative (semantics p) (asm_istep (comp_of_main p)) t. + +Mem.alloc_left_unmapped_inject: + forall (f : meminj) (m1 m2 : mem) (c : compartment) (lo hi : Z) (m1' : Mem.mem') (b1 : block), + Mem.inject f m1 m2 -> Mem.alloc m1 c lo hi = (m1', b1) -> exists f' : meminj, Mem.inject f' m1' m2 /\ inject_incr f f' /\ f' b1 = None /\ (forall b : block, b <> b1 -> f' b = f b) + +Mem.free_left_inject: forall (f : meminj) (m1 m2 : mem) (b : block) (lo hi : Z) (cp : compartment) (m1' : mem), Mem.inject f m1 m2 -> Mem.free m1 b lo hi cp = Some m1' -> Mem.inject f m1' m2 + +Mem.free_right_inject: + forall (f : meminj) (m1 m2 : mem) (b : block) (lo hi : Z) (cp : compartment) (m2' : mem), + Mem.inject f m1 m2 -> + Mem.free m2 b lo hi cp = Some m2' -> + (forall (b1 : block) (delta ofs : Z) (k : perm_kind) (p : permission), f b1 = Some (b, delta) -> Mem.perm m1 b1 ofs k p -> lo <= ofs + delta < hi -> False) -> Mem.inject f m1 m2' + +End PROOF. From 7adb5cd9dafb440d38761fc6a803dc27433676bb Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 10 May 2023 17:10:54 +0200 Subject: [PATCH 046/174] WIP: fixing... --- security/BtFromAsm.v | 265 ++++++++++++++++++++++++++++++++++++------- 1 file changed, 224 insertions(+), 41 deletions(-) diff --git a/security/BtFromAsm.v b/security/BtFromAsm.v index ba0c0e1a97..42dfaa48c8 100644 --- a/security/BtFromAsm.v +++ b/security/BtFromAsm.v @@ -5,11 +5,18 @@ Require Import AST Linking Smallstep Events Behaviors. Require Import Split. Require Import riscV.Asm. -Require Import BtInfoAsm BtBasics. +Require Import BtInfoAsm. +(* BtBasics. *) Section WELLFORMED. + Definition fd_sig (fd: fundef): signature := + match fd with + | Internal f => fn_sig f + | External ef => ef_sig ef + end. + (* Variant sf_cont_type : Type := | sf_cont: block -> signature -> sf_cont_type. *) Variant sf_cont_type : Type := | sf_cont: block -> sf_cont_type. Definition sf_conts := list sf_cont_type. @@ -20,33 +27,7 @@ Section WELLFORMED. cur m1 sf : info_asm_sem_wf ge cur m1 sf nil - | info_asm_sem_wf_intra_call_external - cur m1 sf ev ik tl - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - ef res m2 - (EXTEV: external_call_event_match_common ef ev ge cp m1 res m2) - fb - (IK: ik = info_external fb (ef_sig ef)) - fid - (INV: Genv.invert_symbol ge fb = Some fid) - (ISEXT: Genv.find_funct_ptr ge fb = Some (AST.External ef)) - (ALLOWED: Genv.allowed_call ge cp (Vptr fb Ptrofs.zero)) - (INTRA: Genv.type_of_call ge cp (Genv.find_comp ge (Vptr fb Ptrofs.zero)) <> Genv.CrossCompartmentCall) - (NEXT: info_asm_sem_wf ge cur m2 sf tl) - : - info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) - | info_asm_sem_wf_builtin - cur m1 sf ev ik tl - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - ef res m2 - (EXT: external_call_event_match_common ef ev ge cp m1 res m2) - (IK: ik = info_builtin ef) - (NEXT: info_asm_sem_wf ge cur m2 sf tl) - : - info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) - | info_asm_sem_wf_cross_call_internal + | info_asm_sem_wf_cross_call cur m1 sf ev ik tl cp (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) @@ -64,15 +45,7 @@ Section WELLFORMED. (NPTR: Forall not_ptr args) (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) (ESM: eventval_list_match ge evargs (sig_args sg) args) - callee_f - (INTERNAL: fd = AST.Internal callee_f) - (* TODO: separate this; - might be better to upgrade Asm semantics to actually refer to its fn_sig. - Note that it's not possible to recover Clight fun type data from trace since - there can be conflicts, since Asm semantics actually allows non-fixed sigs. - *) - (SIG: sg = Asm.fn_sig callee_f) - (* internal call: memory changes in Clight-side, so need inj-relation *) + (SIG: sg = fd_sig fd) (NEXT: info_asm_sem_wf ge b m1 ((sf_cont cur) :: sf) tl) : info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) @@ -98,6 +71,32 @@ Section WELLFORMED. (NEXT: info_asm_sem_wf ge b_c m1 sf_tl tl) : info_asm_sem_wf ge cur m1 ((sf_cont b_c) :: sf_tl) ((ev, ik) :: tl) + | info_asm_sem_wf_intra_call_external + cur m1 sf ev ik tl + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + ef res m2 + (EXTEV: external_call_event_match_common ef ev ge cp m1 res m2) + fb + (IK: ik = info_external fb (ef_sig ef)) + fid + (INV: Genv.invert_symbol ge fb = Some fid) + (ISEXT: Genv.find_funct_ptr ge fb = Some (AST.External ef)) + (ALLOWED: Genv.allowed_call ge cp (Vptr fb Ptrofs.zero)) + (INTRA: Genv.type_of_call ge cp (Genv.find_comp ge (Vptr fb Ptrofs.zero)) <> Genv.CrossCompartmentCall) + (NEXT: info_asm_sem_wf ge cur m2 sf tl) + : + info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) + | info_asm_sem_wf_builtin + cur m1 sf ev ik tl + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + ef res m2 + (EXT: external_call_event_match_common ef ev ge cp m1 res m2) + (IK: ik = info_builtin ef) + (NEXT: info_asm_sem_wf ge cur m2 sf tl) + : + info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) | info_asm_sem_wf_cross_call_external1 (* early cut at call event *) cur m1 sf ev ik @@ -194,6 +193,185 @@ Section WELLFORMED. info_asm_sem_wf ge cur m1 sf ((ev1, ik1) :: (itr ++ ((ev3, ik3) :: tl))) . + (* Inductive info_asm_sem_wf (ge: Asm.genv) : block -> mem -> sf_conts -> itrace -> Prop := *) + (* | info_asm_sem_wf_base *) + (* cur m1 sf *) + (* : *) + (* info_asm_sem_wf ge cur m1 sf nil *) + (* | info_asm_sem_wf_cross_call_internal *) + (* cur m1 sf ev ik tl *) + (* cp *) + (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) + (* cp' fid evargs *) + (* (EV: ev = Event_call cp cp' fid evargs) *) + (* sg *) + (* (IK: ik = info_call not_cross_ext sg) *) + (* b *) + (* (FINDB: Genv.find_symbol ge fid = Some b) *) + (* fd *) + (* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) *) + (* (CP': cp' = comp_of fd) *) + (* (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) *) + (* args *) + (* (NPTR: Forall not_ptr args) *) + (* (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) *) + (* (ESM: eventval_list_match ge evargs (sig_args sg) args) *) + (* callee_f *) + (* (INTERNAL: fd = AST.Internal callee_f) *) + (* (* TODO: separate this; *) + (* might be better to upgrade Asm semantics to actually refer to its fn_sig. *) + (* Note that it's not possible to recover Clight fun type data from trace since *) + (* there can be conflicts, since Asm semantics actually allows non-fixed sigs. *) + (* *) *) + (* (SIG: sg = Asm.fn_sig callee_f) *) + (* (* internal call: memory changes in Clight-side, so need inj-relation *) *) + (* (NEXT: info_asm_sem_wf ge b m1 ((sf_cont cur) :: sf) tl) *) + (* : *) + (* info_asm_sem_wf ge ir_internal cur m1 sf ((ev, ik) :: tl) *) + (* | info_asm_sem_wf_cross_return_internal *) + (* cur m1 ev ik tl *) + (* cp *) + (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) + (* cp_c evres *) + (* (EV: ev = Event_return cp_c cp evres) *) + (* sg *) + (* (IK: ik = info_return sg) *) + (* cur_f *) + (* (INTERNAL: Genv.find_funct_ptr ge cur = Some (AST.Internal cur_f)) *) + (* (* TODO: separate this *) *) + (* (SIG: sg = Asm.fn_sig cur_f) *) + (* (CROSS: Genv.type_of_call ge cp_c cp = Genv.CrossCompartmentCall) *) + (* res *) + (* (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) res) *) + (* (NPTR: not_ptr res) *) + (* b_c sf_tl *) + (* (CPC: cp_c = Genv.find_comp ge (Vptr b_c Ptrofs.zero)) *) + (* (* internal return: memory changes in Clight-side, so need inj-relation *) *) + (* (NEXT: info_asm_sem_wf ge b_c m1 sf_tl tl) *) + (* : *) + (* info_asm_sem_wf ge cur m1 ((sf_cont b_c) :: sf_tl) ((ev, ik) :: tl) *) + (* | info_asm_sem_wf_intra_call_external *) + (* cur m1 sf ev ik tl *) + (* cp *) + (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) + (* ef res m2 *) + (* (EXTEV: external_call_event_match_common ef ev ge cp m1 res m2) *) + (* fb *) + (* (IK: ik = info_external fb (ef_sig ef)) *) + (* fid *) + (* (INV: Genv.invert_symbol ge fb = Some fid) *) + (* (ISEXT: Genv.find_funct_ptr ge fb = Some (AST.External ef)) *) + (* (ALLOWED: Genv.allowed_call ge cp (Vptr fb Ptrofs.zero)) *) + (* (INTRA: Genv.type_of_call ge cp (Genv.find_comp ge (Vptr fb Ptrofs.zero)) <> Genv.CrossCompartmentCall) *) + (* (NEXT: info_asm_sem_wf ge cur m2 sf tl) *) + (* : *) + (* info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) *) + (* | info_asm_sem_wf_builtin *) + (* cur m1 sf ev ik tl *) + (* cp *) + (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) + (* ef res m2 *) + (* (EXT: external_call_event_match_common ef ev ge cp m1 res m2) *) + (* (IK: ik = info_builtin ef) *) + (* (NEXT: info_asm_sem_wf ge cur m2 sf tl) *) + (* : *) + (* info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) *) + (* | info_asm_sem_wf_cross_call_external1 *) + (* (* early cut at call event *) *) + (* cur m1 sf ev ik *) + (* cp *) + (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) + (* cp' fid evargs *) + (* (EV: ev = Event_call cp cp' fid evargs) *) + (* sg *) + (* (IK: ik = info_call is_cross_ext sg) *) + (* b *) + (* (FINDB: Genv.find_symbol ge fid = Some b) *) + (* fd *) + (* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) *) + (* (CP': cp' = comp_of fd) *) + (* (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) *) + (* args *) + (* (NPTR: Forall not_ptr args) *) + (* (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) *) + (* (ESM: eventval_list_match ge evargs (sig_args sg) args) *) + (* ef *) + (* (EXTERNAL: fd = AST.External ef) *) + (* (* TODO: separate this *) *) + (* (SIG: sg = ef_sig ef) *) + (* : *) + (* info_asm_sem_wf ge cur m1 sf ((ev, ik) :: nil) *) + (* | info_asm_sem_wf_cross_call_external2 *) + (* (* early cut at call-ext_call event *) *) + (* cur m1 sf ev1 ik1 *) + (* cp *) + (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) + (* cp' fid evargs *) + (* (EV: ev1 = Event_call cp cp' fid evargs) *) + (* sg *) + (* (IK: ik1 = info_call is_cross_ext sg) *) + (* b *) + (* (FINDB: Genv.find_symbol ge fid = Some b) *) + (* fd *) + (* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) *) + (* (CP': cp' = comp_of fd) *) + (* (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) *) + (* args *) + (* (NPTR: Forall not_ptr args) *) + (* (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) *) + (* (ESM: eventval_list_match ge evargs (sig_args sg) args) *) + (* ef *) + (* (EXTERNAL: fd = AST.External ef) *) + (* (* TODO: separate this *) *) + (* (SIG: sg = ef_sig ef) *) + (* (* external call part *) *) + (* tr vres m2 *) + (* (EXTCALL: external_call ef ge cp args m1 tr vres m2) *) + (* itr *) + (* (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) *) + (* : *) + (* info_asm_sem_wf ge cur m1 sf ((ev1, ik1) :: itr) *) + (* | info_asm_sem_wf_cross_call_external3 *) + (* (* full call-ext_call-return event *) *) + (* cur m1 sf ev1 ik1 *) + (* cp *) + (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) + (* cp' fid evargs *) + (* (EV: ev1 = Event_call cp cp' fid evargs) *) + (* sg *) + (* (IK: ik1 = info_call is_cross_ext sg) *) + (* b *) + (* (FINDB: Genv.find_symbol ge fid = Some b) *) + (* fd *) + (* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) *) + (* (CP': cp' = comp_of fd) *) + (* (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) *) + (* args *) + (* (NPTR: Forall not_ptr args) *) + (* (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) *) + (* (ESM: eventval_list_match ge evargs (sig_args sg) args) *) + (* ef *) + (* (EXTERNAL: fd = AST.External ef) *) + (* (* TODO: separate this *) *) + (* (SIG: sg = ef_sig ef) *) + (* (* external call part *) *) + (* tr vres m2 *) + (* (EXTCALL: external_call ef ge cp args m1 tr vres m2) *) + (* itr *) + (* (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) *) + (* (* return part *) *) + (* ev3 ik3 tl *) + (* evres *) + (* (EV: ev3 = Event_return cp cp' evres) *) + (* sg *) + (* (IK: ik3 = info_return sg) *) + (* (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) vres) *) + (* (NPTR: not_ptr vres) *) + (* (NEXT: info_asm_sem_wf ge cur m2 sf tl) *) + (* : *) + (* info_asm_sem_wf ge cur m1 sf ((ev1, ik1) :: (itr ++ ((ev3, ik3) :: tl))) *) + (* . *) + (* TODO *) (* we need a more precise invariant for the proof; counters, mem_inj, env, cont, state *) @@ -272,14 +450,19 @@ Section PROOF. (STATE: s = State st rs m) b ofs f (RSPC: rs PC = Vptr b ofs) - (INT: Genv.find_funct_ptr ge b = Some (Internal f)) + (FUN: Genv.find_funct_ptr ge b = Some (Internal f)) cur m_ir k - (MATCHB: match_block ge cur b) - (MATCHM: match_mem ge m_ir m) - (MATCHS: match_stack k st) + (MB: match_block ge cur b) + (MM: match_mem ge m_ir m) + (MS: match_stack k st) : info_asm_sem_wf ge cur m_ir k it. Proof. + remember (asm_istep cp) as istep. revert dependent cp. revert st rs m STATE b ofs f RSPC FUN cur m_ir k MB MM MS. induction STAR; intros; subst. + { constructor 1. } + inv H. + - rewrite RSPC in H3. inv H3. rewrite FUN in H4. inv H4. + (* TODO *) From 697e3ccc7c23d5081dca8844cd9e7f4c3b7920fb Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 12 May 2023 12:16:15 +0200 Subject: [PATCH 047/174] WIP --- riscV/Asm.v | 8 +++++- security/BtFromAsm.v | 68 ++++++++++++++++++++++++++++---------------- security/BtInfoAsm.v | 12 +++++--- 3 files changed, 59 insertions(+), 29 deletions(-) diff --git a/riscV/Asm.v b/riscV/Asm.v index 5693b0d620..c680aa9969 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,12 @@ 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. + Inductive step: state -> trace -> state -> Prop := | exec_step_internal: forall b ofs f i rs m rs' m' b' ofs' st cp, diff --git a/security/BtFromAsm.v b/security/BtFromAsm.v index 42dfaa48c8..e9ae3a275d 100644 --- a/security/BtFromAsm.v +++ b/security/BtFromAsm.v @@ -5,18 +5,11 @@ Require Import AST Linking Smallstep Events Behaviors. Require Import Split. Require Import riscV.Asm. -Require Import BtInfoAsm. -(* BtBasics. *) +Require Import BtInfoAsm BtBasics. Section WELLFORMED. - Definition fd_sig (fd: fundef): signature := - match fd with - | Internal f => fn_sig f - | External ef => ef_sig ef - end. - (* Variant sf_cont_type : Type := | sf_cont: block -> signature -> sf_cont_type. *) Variant sf_cont_type : Type := | sf_cont: block -> sf_cont_type. Definition sf_conts := list sf_cont_type. @@ -45,7 +38,7 @@ Section WELLFORMED. (NPTR: Forall not_ptr args) (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) (ESM: eventval_list_match ge evargs (sig_args sg) args) - (SIG: sg = fd_sig fd) + (SIG: sg = Asm.funsig fd) (NEXT: info_asm_sem_wf ge b m1 ((sf_cont cur) :: sf) tl) : info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) @@ -59,7 +52,7 @@ Section WELLFORMED. (IK: ik = info_return sg) cur_f (INTERNAL: Genv.find_funct_ptr ge cur = Some (AST.Internal cur_f)) - (* TODO: separate this *) + (* Follows from cross call - stack has the sig *) (SIG: sg = Asm.fn_sig cur_f) (CROSS: Genv.type_of_call ge cp_c cp = Genv.CrossCompartmentCall) res @@ -118,7 +111,6 @@ Section WELLFORMED. (ESM: eventval_list_match ge evargs (sig_args sg) args) ef (EXTERNAL: fd = AST.External ef) - (* TODO: separate this *) (SIG: sg = ef_sig ef) : info_asm_sem_wf ge cur m1 sf ((ev, ik) :: nil) @@ -143,7 +135,6 @@ Section WELLFORMED. (ESM: eventval_list_match ge evargs (sig_args sg) args) ef (EXTERNAL: fd = AST.External ef) - (* TODO: separate this *) (SIG: sg = ef_sig ef) (* external call part *) tr vres m2 @@ -173,7 +164,6 @@ Section WELLFORMED. (ESM: eventval_list_match ge evargs (sig_args sg) args) ef (EXTERNAL: fd = AST.External ef) - (* TODO: separate this *) (SIG: sg = ef_sig ef) (* external call part *) tr vres m2 @@ -387,8 +377,8 @@ Section MATCH. Definition match_stack (sf: sf_conts) (st: stack) := Forall2 match_stack_type sf st. - Definition match_block (ge: Asm.genv) (cur: block) (b: block) : Prop := - Genv.find_comp ge (Vptr cur Ptrofs.zero) = Genv.find_comp ge (Vptr b Ptrofs.zero). + Definition match_cp (ge: Asm.genv) (cur: block) (cp: compartment) : Prop := + Genv.find_comp ge (Vptr cur Ptrofs.zero) = cp. Definition meminj_ge {F V} (ge: Genv.t F V): meminj := fun b => match Genv.invert_symbol ge b with @@ -401,6 +391,37 @@ Section MATCH. Definition match_mem (ge: Asm.genv) (m_ir m_asm: mem): Prop := Mem.inject (meminj_ge ge) m_asm m_ir. + 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_stack cpm (ge: Asm.genv) (rs: regset) (sk: stack) := + match rs PC with + | Vptr b _ => match Genv.find_funct_ptr ge b with + | Some (External ef) => Genv.find_comp_ignore_offset ge (rs RA) = callee_comp cpm sk + | _ => True + end + | _ => True + end. + + (* Definition wf_state cpm (ge: Asm.genv) (s: state) := *) + (* match s with *) + (* | State sk rs m => match rs PC with *) + (* | Vptr b _ => match Genv.find_funct_ptr ge b with *) + (* | Some (External ef) => Genv.find_comp_ignore_offset ge (rs RA) = callee_comp cpm sk *) + (* | _ => True *) + (* end *) + (* | _ => True *) + (* end *) + (* | _ => False *) + (* end. *) + + (* Definition external_call_mem_inject_gen ef := ec_mem_inject (external_call_spec ef). *) (* external_call_mem_inject: *) @@ -444,21 +465,20 @@ Section PROOF. (* If main is External, treat it in a different case - the trace can start with Event_syscall, without a preceding Event_call *) Lemma from_info_asm_sem_wf - ge cp s s' it + cpm ge cp s s' it (STAR: istar (asm_istep cp) ge s it s') - st rs m - (STATE: s = State st rs m) - b ofs f - (RSPC: rs PC = Vptr b ofs) - (FUN: Genv.find_funct_ptr ge b = Some (Internal f)) + sk rs m + (STATE: s = State sk rs m) + (WFSK: wf_stack ge sk) + (WFRS: wf_regset_stack cpm ge rs sk) cur m_ir k - (MB: match_block ge cur b) + (MC: match_cp ge cur (Genv.find_comp_ignore_offset ge (rs PC))) (MM: match_mem ge m_ir m) - (MS: match_stack k st) + (MS: match_stack k sk) : info_asm_sem_wf ge cur m_ir k it. Proof. - remember (asm_istep cp) as istep. revert dependent cp. revert st rs m STATE b ofs f RSPC FUN cur m_ir k MB MM MS. induction STAR; intros; subst. + remember (asm_istep cp) as istep. revert dependent cp. revert sk rs m STATE b ofs RSPC FUN cur m_ir k MB MM MS. induction STAR; intros; subst. { constructor 1. } inv H. - rewrite RSPC in H3. inv H3. rewrite FUN in H4. inv H4. diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index b666b3775b..bc05faa153 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -366,6 +366,9 @@ Section ASMISTEP. | _ => not_cross_ext end in it = map (fun e => (e, info_call ce sig)) t), + forall (CROSS_SIG: 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 /\ Asm.funsig fd = sig) + ), asm_istep (State st rs m) it (State st' rs' m') | exec_asm_istep_internal_return: forall b ofs f i rs m rs' cp m' st, @@ -440,6 +443,7 @@ Section ASMITR. Definition asm_has_initial_trace (p: Asm.program) (t: trace): Prop := semantics_has_initial_trace_prefix (Asm.semantics p) t. + (* TODO: fix Asm sem *) Lemma asm_star_tr_implies_istar_info_tr (p: Asm.program) (t: trace) (s s': Asm.state) @@ -456,7 +460,7 @@ Section ASMITR. auto. - pose proof EV as EV0. inv EV0. + exists (it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 2; eauto. } + { econstructor 2; eauto. admit. } auto. + assert (CASES: (exists ef, Genv.find_funct_ptr (Genv.globalenv p) b' = Some (External ef)) \/ ((exists intf, Genv.find_funct_ptr (Genv.globalenv p) b' = Some (Internal intf)) \/ (Genv.find_funct_ptr (Genv.globalenv p) b' = None))). @@ -464,11 +468,11 @@ Section ASMITR. destruct CASES as [EXT | ELSE]. * exists ((Event_call (comp_of f) (Genv.find_comp_ignore_offset (Genv.globalenv p) (Vptr b' ofs')) i0 vl, info_call is_cross_ext sig) :: it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 2; eauto. } + { econstructor 2; eauto. admit. } simpl. destruct EXT. rewrite H8. unfold Genv.find_comp_ignore_offset in H. rewrite H. auto. * exists ((Event_call (comp_of f) (Genv.find_comp_ignore_offset (Genv.globalenv p) (Vptr b' ofs')) i0 vl, info_call not_cross_ext sig) :: it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 2; eauto. } + { econstructor 2; eauto. admit. } simpl. destruct ELSE. destruct H8. rewrite H8. auto. rewrite H8. auto. - exists (it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. { econstructor 3; eauto. } @@ -491,7 +495,7 @@ Section ASMITR. exists s2'. econstructor 2. 2: eapply ISTAR. { econstructor 6; eauto. } auto. - Qed. + Admitted. Lemma asm_tr_implies_info_tr (p: Asm.program) (t: trace) From 762fa56016ba074f0d9ba40d1674623f7deb684a Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 12 May 2023 15:17:08 +0200 Subject: [PATCH 048/174] WIP --- security/BtFromAsm.v | 54 ++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 49 insertions(+), 5 deletions(-) diff --git a/security/BtFromAsm.v b/security/BtFromAsm.v index e9ae3a275d..cb523d911a 100644 --- a/security/BtFromAsm.v +++ b/security/BtFromAsm.v @@ -463,10 +463,22 @@ End MATCH. Section PROOF. + 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. + (* If main is External, treat it in a different case - the trace can start with Event_syscall, without a preceding Event_call *) Lemma from_info_asm_sem_wf - cpm ge cp s s' it - (STAR: istar (asm_istep cp) ge s it s') + cpm ge s s' it + (WFGE: wf_ge ge) + (STAR: istar (asm_istep cpm) ge s it s') sk rs m (STATE: s = State sk rs m) (WFSK: wf_stack ge sk) @@ -478,10 +490,42 @@ Section PROOF. : info_asm_sem_wf ge cur m_ir k it. Proof. - remember (asm_istep cp) as istep. revert dependent cp. revert sk rs m STATE b ofs RSPC FUN cur m_ir k MB MM MS. induction STAR; intros; subst. + remember (asm_istep cpm) as istep. revert dependent cpm. revert sk rs m STATE WFSK cur m_ir k MC MM MS. induction STAR; intros; subst. { constructor 1. } - inv H. - - rewrite RSPC in H3. inv H3. rewrite FUN in H4. inv H4. + inv H; simpl. + - assert (INTRA: Genv.find_comp ge (Vptr cur Ptrofs.zero) = Genv.find_comp_ignore_offset ge (rs' PC)). + { rewrite MC. rewrite NEXTPC, <- ALLOWED. unfold Genv.find_comp_ignore_offset. rewrite H3. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H4. auto. } + destruct (Genv.find_funct_ptr ge b') eqn:NEXTFUN. destruct f0. + + eapply IHSTAR; try reflexivity. all: auto. + { admit. (* mem *) } + { unfold wf_regset_stack. rewrite NEXTPC, NEXTFUN. auto. } + + inv STAR. + { constructor 1. } + inv H. + all: rewrite NEXTPC in H8; inv H8; rewrite NEXTFUN in H11; inv H11. + inv H0. + { exploit external_call_trace_length. eauto. intros EVLEN. destruct t. + - simpl. constructor 1. + - destruct t; simpl in EVLEN. 2: lia. + simpl. pose proof NEXTFUN as NF0. unfold Genv.find_funct_ptr in NF0. destruct (Genv.find_def ge b0) eqn:FDB0; [|inv NF0]. destruct g; inv NF0. + exploit wf_ge_block_to_id; eauto. intros (fid & INV). + econstructor 4; try reflexivity; auto. + { admit. } + { eauto. } + { unfold Genv.allowed_call. right; left. rewrite <- NEXTPC. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. auto. } + { unfold Genv.type_of_call. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. rewrite Pos.eqb_refl. intros F. inv F. } + { constructor 1. } + } + + + eapply Genv.find_invert_symbol. + + + + +external_call_trace_length: + forall (ef : external_function) (ge : Senv.t) (c : compartment) (vargs : list val) (m : mem) (t : trace) (vres : val) (m' : mem), external_call ef ge c vargs m t vres m' -> (Datatypes.length t <= 1)%nat + From f159907959c24d3386a944ba21d7c52211ecc713 Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 12 May 2023 18:55:41 +0200 Subject: [PATCH 049/174] WIP --- security/BtFromAsm.v | 14 ++++-- security/BtInfoAsm.v | 106 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 117 insertions(+), 3 deletions(-) diff --git a/security/BtFromAsm.v b/security/BtFromAsm.v index cb523d911a..d1b457b90b 100644 --- a/security/BtFromAsm.v +++ b/security/BtFromAsm.v @@ -510,16 +510,24 @@ Section PROOF. simpl. pose proof NEXTFUN as NF0. unfold Genv.find_funct_ptr in NF0. destruct (Genv.find_def ge b0) eqn:FDB0; [|inv NF0]. destruct g; inv NF0. exploit wf_ge_block_to_id; eauto. intros (fid & INV). econstructor 4; try reflexivity; auto. - { admit. } + { admit. (* ext call sem *) } { eauto. } { unfold Genv.allowed_call. right; left. rewrite <- NEXTPC. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. auto. } { unfold Genv.type_of_call. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. rewrite Pos.eqb_refl. intros F. inv F. } { constructor 1. } } + inv H; simpl in *. + + (* TODO *) + + eapply IHSTAR. - eapply Genv.find_invert_symbol. - +istar_ind: + forall (genv state : Type) (step : genv -> state -> itrace -> state -> Prop) (ge : genv) (P : state -> itrace -> state -> Prop), + (forall s : state, P s nil s) -> + (forall (s1 : state) (t1 : itrace) (s2 : state) (t2 : itrace) (s3 : state) (t : itrace), step ge s1 t1 s2 -> istar step ge s2 t2 s3 -> P s2 t2 s3 -> t = t1 ++ t2 -> P s1 t s3) -> + forall (y : state) (i : itrace) (y0 : state), istar step ge y i y0 -> P y i y0 diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index bc05faa153..b11d302a71 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -193,6 +193,112 @@ Section INFORMATIVE. | istar_step : forall (s1 : state) (t1 : itrace) (s2 : state) (t2 : itrace) (s3 : state) (t : itrace), step ge s1 t1 s2 -> istar step ge s2 t2 s3 -> t = t1 ++ t2 -> istar step ge s1 t s3. + Lemma istar_ind2: + forall (genv state : Type) (step : genv -> state -> itrace -> state -> Prop) (ge : genv) (P : state -> itrace -> state -> Prop), + (forall s : state, P s nil s) -> + (forall (s1 : state) (t1 : itrace) (s2 : state) (t2 : itrace) (s3 : state) (t : itrace), step ge s1 t1 s2 -> istar step ge s2 t2 s3 -> P s2 t2 s3 -> t = t1 ++ t2 -> P s1 t s3) -> + forall (y : state) (i : itrace) (y0 : state), istar step ge y i y0 -> P y i y0. + Proof. + intros genv state step ge P. fix IH 6. intros. inv H1. + { eapply H. } + eapply H0. eauto. eauto. 2: auto. + eapply IH. auto. apply H0. apply H3. + Qed. + + Definition istar_cut {genv state : Type} (step : genv -> state -> itrace -> state -> Prop) (ge : genv) : state -> itrace -> state -> state -> itrace -> Prop := + fun s0 tr s2 s1 tr1 => (istar step ge s0 tr s2) -> exists tr0, (tr = tr0 ++ tr1) /\ (istar step ge s0 tr0 s1) /\ (istar step ge s1 tr1 s2). + + Lemma istar_ind_clo: + forall (genv state : Type) (step : genv -> state -> itrace -> state -> Prop) (ge : genv) (P : state -> itrace -> state -> Prop), + (forall s : state, P s nil s) -> + (forall (s1 : state) (t1 : itrace) (s2 : state) (t2 : itrace) (s3 : state) (t : itrace), + step ge s1 t1 s2 -> istar step ge s2 t2 s3 -> t = t1 ++ t2 -> + (exists s2' t2', (istar_cut step ge s2 t2 s3 s2' t2') /\ (P s2' t2' s3 -> P s1 t s3))) -> + forall (y : state) (i : itrace) (y0 : state), istar step ge y i y0 -> P y i y0. + Proof. + intros genv state step ge P. fix IH 6. intros. inv H1. + { eapply H. } + exploit H0; eauto. intros (s2' & t2' & CUT & IMP). apply IMP. + eapply CUT in H3. destruct H3 as (tr0 & TR & ISTAR0 & ISTAR1). + eapply IH. auto. + 2: auto. + + Guarded. + + + eapply H0. eauto. eauto. 2: auto. + intros. + + eapply IH. auto. + eapply H0. + Guarded. + auto. + Qed. + + + + Lemma istar_ind_clo: + forall (genv state : Type) (step : genv -> state -> itrace -> state -> Prop) (ge : genv) (P : state -> itrace -> state -> Prop), + (forall s : state, P s nil s) -> + (forall (s1 : state) (t1 : itrace) (s2 : state) (t2 : itrace) (s3 : state) (t : itrace), + step ge s1 t1 s2 -> istar step ge s2 t2 s3 -> + (forall s2' t2a t2b, (istar step ge s2 t2a s2') -> (istar step ge s2' t2b s3) -> (t2 = t2a ++ t2b) -> P s2' t2b s3) -> t = t1 ++ t2 -> P s1 t s3) -> + forall (y : state) (i : itrace) (y0 : state), istar step ge y i y0 -> P y i y0. + Proof. + intros genv state step ge P. fix IH 6. intros. inv H1. + { eapply H. } + eapply H0. eauto. eauto. 2: auto. + intros. eapply IH. auto. 2: + + inv H4. auto. + + + + inv H4. + { auto. } + eapply H0. eauto. eauto. 2: auto. + intros. eapply IH. 1: auto. + 2: apply H5. + Guarded. + + + Guarded. + + eapply IH. auto. eapply H0. + + apply H4. + + Guarded. + + intros. inv H7. + + { eapply H0. eauto. econstructor 1. 2: auto. Guarded. apply H8. } + Guarded. + + + apply H0. auto. 2: auto. + intros. eapply H0. 4: eapply H9. eauto. auto. apply H8. + Qed. + + Guarded. + + eapply IH. auto. 2: auto. intros. eapply H0; eauto. + Qed. + + + + eapply IH; eauto. econstructor 2; eauto. + Guarded. + Qed. + + + eapply H0. eapply H2. eapply H3. 2: auto. intros. + eapply IH. auto. 2: auto. intros. + + { + + Guarded. + (* Record isemantics : Type := *) (* iSemantics_gen *) From 5d87590afe627436aa0547aac98f78fbe8fee3cb Mon Sep 17 00:00:00 2001 From: ldj Date: Sun, 14 May 2023 10:16:50 +0200 Subject: [PATCH 050/174] WIP --- security/BtFromAsm.v | 13 +++-- security/BtInfoAsm.v | 121 ++++++------------------------------------- 2 files changed, 26 insertions(+), 108 deletions(-) diff --git a/security/BtFromAsm.v b/security/BtFromAsm.v index d1b457b90b..cfb2605952 100644 --- a/security/BtFromAsm.v +++ b/security/BtFromAsm.v @@ -490,15 +490,19 @@ Section PROOF. : info_asm_sem_wf ge cur m_ir k it. Proof. - remember (asm_istep cpm) as istep. revert dependent cpm. revert sk rs m STATE WFSK cur m_ir k MC MM MS. induction STAR; intros; subst. + apply measure_istar in STAR. destruct STAR as (n & STAR). + move n before ge. revert s s' it WFGE STAR sk rs m STATE WFSK WFRS cur m_ir k MC MM MS. + pattern n. apply (well_founded_induction Nat.lt_wf_0). intros m IH. intros. + inv STAR; subst. + (* remember (asm_istep cpm) as istep. revert dependent cpm. revert sk rs m STATE WFSK cur m_ir k MC MM MS. induction STAR; intros; subst. *) { constructor 1. } - inv H; simpl. + rename H0 into STAR. inv H; simpl. - assert (INTRA: Genv.find_comp ge (Vptr cur Ptrofs.zero) = Genv.find_comp_ignore_offset ge (rs' PC)). { rewrite MC. rewrite NEXTPC, <- ALLOWED. unfold Genv.find_comp_ignore_offset. rewrite H3. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H4. auto. } destruct (Genv.find_funct_ptr ge b') eqn:NEXTFUN. destruct f0. - + eapply IHSTAR; try reflexivity. all: auto. - { admit. (* mem *) } + + eapply IH; try reflexivity. 3: eauto. all: auto. { unfold wf_regset_stack. rewrite NEXTPC, NEXTFUN. auto. } + { admit. (* mem *) } + inv STAR. { constructor 1. } inv H. @@ -517,6 +521,7 @@ Section PROOF. { constructor 1. } } inv H; simpl in *. + (* TODO *) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index b11d302a71..b3611b5fe5 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -193,111 +193,24 @@ Section INFORMATIVE. | istar_step : forall (s1 : state) (t1 : itrace) (s2 : state) (t2 : itrace) (s3 : state) (t : itrace), step ge s1 t1 s2 -> istar step ge s2 t2 s3 -> t = t1 ++ t2 -> istar step ge s1 t s3. - Lemma istar_ind2: - forall (genv state : Type) (step : genv -> state -> itrace -> state -> Prop) (ge : genv) (P : state -> itrace -> state -> Prop), - (forall s : state, P s nil s) -> - (forall (s1 : state) (t1 : itrace) (s2 : state) (t2 : itrace) (s3 : state) (t : itrace), step ge s1 t1 s2 -> istar step ge s2 t2 s3 -> P s2 t2 s3 -> t = t1 ++ t2 -> P s1 t s3) -> - forall (y : state) (i : itrace) (y0 : state), istar step ge y i y0 -> P y i y0. - Proof. - intros genv state step ge P. fix IH 6. intros. inv H1. - { eapply H. } - eapply H0. eauto. eauto. 2: auto. - eapply IH. auto. apply H0. apply H3. - Qed. - - Definition istar_cut {genv state : Type} (step : genv -> state -> itrace -> state -> Prop) (ge : genv) : state -> itrace -> state -> state -> itrace -> Prop := - fun s0 tr s2 s1 tr1 => (istar step ge s0 tr s2) -> exists tr0, (tr = tr0 ++ tr1) /\ (istar step ge s0 tr0 s1) /\ (istar step ge s1 tr1 s2). - - Lemma istar_ind_clo: - forall (genv state : Type) (step : genv -> state -> itrace -> state -> Prop) (ge : genv) (P : state -> itrace -> state -> Prop), - (forall s : state, P s nil s) -> - (forall (s1 : state) (t1 : itrace) (s2 : state) (t2 : itrace) (s3 : state) (t : itrace), - step ge s1 t1 s2 -> istar step ge s2 t2 s3 -> t = t1 ++ t2 -> - (exists s2' t2', (istar_cut step ge s2 t2 s3 s2' t2') /\ (P s2' t2' s3 -> P s1 t s3))) -> - forall (y : state) (i : itrace) (y0 : state), istar step ge y i y0 -> P y i y0. + Inductive istar_measure {genv state : Type} (step : genv -> state -> itrace -> state -> Prop) (ge : genv) : nat -> state -> itrace -> state -> Prop := + istar_measure_refl : forall s : state, istar_measure step ge O s nil s + | istar_measure_step : forall (n: nat) (s1 : state) (t1 : itrace) (s2 : state) (t2 : itrace) (s3 : state) (t : itrace), + step ge s1 t1 s2 -> istar_measure step ge n s2 t2 s3 -> t = t1 ++ t2 -> istar_measure step ge (S n) s1 t s3. + + Lemma measure_istar + genv state + (step : genv -> state -> itrace -> state -> Prop) + (ge : genv) + s0 tr s1 + (STAR: istar step ge s0 tr s1) + : + exists n, istar_measure step ge n s0 tr s1. Proof. - intros genv state step ge P. fix IH 6. intros. inv H1. - { eapply H. } - exploit H0; eauto. intros (s2' & t2' & CUT & IMP). apply IMP. - eapply CUT in H3. destruct H3 as (tr0 & TR & ISTAR0 & ISTAR1). - eapply IH. auto. - 2: auto. - - Guarded. - - - eapply H0. eauto. eauto. 2: auto. - intros. - - eapply IH. auto. - eapply H0. - Guarded. - auto. + induction STAR. + { exists O. constructor 1. } + destruct IHSTAR as (n & NEXT). exists (S n). econstructor 2. eapply H. eapply NEXT. auto. Qed. - - - - Lemma istar_ind_clo: - forall (genv state : Type) (step : genv -> state -> itrace -> state -> Prop) (ge : genv) (P : state -> itrace -> state -> Prop), - (forall s : state, P s nil s) -> - (forall (s1 : state) (t1 : itrace) (s2 : state) (t2 : itrace) (s3 : state) (t : itrace), - step ge s1 t1 s2 -> istar step ge s2 t2 s3 -> - (forall s2' t2a t2b, (istar step ge s2 t2a s2') -> (istar step ge s2' t2b s3) -> (t2 = t2a ++ t2b) -> P s2' t2b s3) -> t = t1 ++ t2 -> P s1 t s3) -> - forall (y : state) (i : itrace) (y0 : state), istar step ge y i y0 -> P y i y0. - Proof. - intros genv state step ge P. fix IH 6. intros. inv H1. - { eapply H. } - eapply H0. eauto. eauto. 2: auto. - intros. eapply IH. auto. 2: - - inv H4. auto. - - - - inv H4. - { auto. } - eapply H0. eauto. eauto. 2: auto. - intros. eapply IH. 1: auto. - 2: apply H5. - Guarded. - - - Guarded. - - eapply IH. auto. eapply H0. - - apply H4. - - Guarded. - - intros. inv H7. - - { eapply H0. eauto. econstructor 1. 2: auto. Guarded. apply H8. } - Guarded. - - - apply H0. auto. 2: auto. - intros. eapply H0. 4: eapply H9. eauto. auto. apply H8. - Qed. - - Guarded. - - eapply IH. auto. 2: auto. intros. eapply H0; eauto. - Qed. - - - - eapply IH; eauto. econstructor 2; eauto. - Guarded. - Qed. - - - eapply H0. eapply H2. eapply H3. 2: auto. intros. - eapply IH. auto. 2: auto. intros. - - { - - Guarded. (* Record isemantics : Type := *) @@ -435,7 +348,7 @@ Section ASMISTEP. (* forall id ofs, *) (* Val.offset_ptr (high_half ge id ofs) (low_half ge id ofs) = Genv.symbol_address ge id ofs. *) - Inductive asm_istep: state -> itrace -> state -> Prop := + Variant asm_istep: state -> itrace -> state -> Prop := | exec_asm_istep_internal: forall b ofs f i rs m rs' m' b' ofs' st cp, rs PC = Vptr b ofs -> From 3c2442cffe389e621c52bdda247e694c5c21e377 Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 15 May 2023 17:03:11 +0200 Subject: [PATCH 051/174] WIP; updated info asm to invoke virtual events --- security/BtFromAsm.v | 8 +- security/BtInfoAsm.v | 219 ++++++++++++++++++++++++++++++++++++------- 2 files changed, 194 insertions(+), 33 deletions(-) diff --git a/security/BtFromAsm.v b/security/BtFromAsm.v index cfb2605952..6a752b7cc6 100644 --- a/security/BtFromAsm.v +++ b/security/BtFromAsm.v @@ -521,7 +521,13 @@ Section PROOF. { constructor 1. } } inv H; simpl in *. - + exploit external_call_trace_length. eauto. intros EVLEN. destruct t. + { simpl. pose proof EV as RETEV. inv RETEV; simpl. + { eapply IH. 3: eauto. all: auto. + assert (STEQ: st' = sk). + + { unfold update_stack_return in STUPD. + econstructor 4. (* TODO *) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index b3611b5fe5..2c9e08f3bd 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -135,11 +135,13 @@ Section INFORMATIVE. (* When a Event_call is is_cross_ext, do not back-translate the following (possible Event_syscall and) Event_return. *) Variant cross_ext := | is_cross_ext | not_cross_ext. + Variant real_virtual := | is_real | is_virtual. + (* Additional information *) Variant info_kind := (* Get information for cross-comp calls and returns *) - | info_call (ce: cross_ext) (sg: signature) - | info_return (sg: signature) + | info_call (ce: cross_ext) (sg: signature) (vr: real_virtual) + | info_return (sg: signature) (vr: real_virtual) (* Get information for inter-comp external calls or builtins *) | info_external (b: block) (sg: signature) | info_builtin (ef: external_function) @@ -154,7 +156,35 @@ Section INFORMATIVE. (* Informative to original *) Definition iev_to_ev (ie: ievent) : event := (fst ie). - Definition itr_to_tr (ies: itrace) : trace := map iev_to_ev ies. + (* Definition itr_to_tr (ies: itrace) : trace := map iev_to_ev ies. *) + + Definition filter_virtual (iev: ievent): bool := + match iev with + | (ev, info_call _ _ is_virtual) | (ev, info_return _ is_virtual) => false + | _ => true + end. + + Definition itr_to_tr (itr: itrace) : trace := map iev_to_ev (filter filter_virtual itr). + + Lemma itr_to_tr_cons + ev tr + : + itr_to_tr (ev :: tr) = if (filter_virtual ev) then (fst ev) :: (itr_to_tr tr) else (itr_to_tr tr). + Proof. unfold itr_to_tr. destruct ev. destruct i; simpl; auto. 1,2: destruct vr; simpl; auto. Qed. + + Lemma itr_to_tr_app + t1 t2 + : + itr_to_tr (t1 ++ t2) = (itr_to_tr t1) ++ (itr_to_tr t2). + Proof. unfold itr_to_tr. rewrite filter_app. rewrite map_app. auto. Qed. + + Lemma filter_map + A B f (m: A -> B) + (l: list A) + (FA: forall a, f (m a) = true) + : + filter f (map m l) = map m l. + Proof. induction l; simpl; auto. rewrite FA. rewrite IHl. auto. Qed. (* Informative behavior *) (* CoInductive itraceinf : Type := iEconsinf : ievent -> itraceinf -> itraceinf. *) @@ -348,6 +378,39 @@ Section ASMISTEP. (* forall id ofs, *) (* Val.offset_ptr (high_half ge id ofs) (low_half ge id ofs) = Genv.symbol_address ge id ofs. *) + 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 => EVfloat Floats.Float.zero + end. + + Definition typ_to_eventvals (ty: list typ): list eventval := map typ_to_eventval ty. + + Definition genv_invert_symbol_total {F V : Type} (ge : Genv.t F V) : block -> ident := + fun b => match Genv.invert_symbol ge b with | Some i => i | None => xH end. + + Inductive call_trace_vr {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> val -> list val -> list typ -> trace -> Prop := + call_trace_vr_intra : forall (cp cp' : compartment) (vf : val) (vargs : list val) (ty : list typ), + Genv.type_of_call ge cp cp' = Genv.InternalCall -> call_trace_vr ge cp cp' vf vargs ty E0 + | call_trace_vr_virtual : forall (cp cp' : compartment) (vf : val) (vargs : list val) (vl : list eventval) (ty : list typ) (b : block) (ofs : ptrofs) (i : ident), + Genv.type_of_call ge cp cp' = Genv.DefaultCompartmentCall -> + vf = Vptr b ofs -> genv_invert_symbol_total ge b = i -> (vl = typ_to_eventvals ty) -> call_trace_vr ge cp cp' vf vargs ty (Event_call cp cp' i vl :: nil) + | call_trace_vr_cross : forall (cp cp' : compartment) (vf : val) (vargs : list val) (vl : list eventval) (ty : list typ) (b : block) (ofs : ptrofs) (i : ident), + Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> + vf = Vptr b ofs -> Genv.invert_symbol ge b = Some i -> eventval_list_match ge vl ty vargs -> call_trace_vr ge cp cp' vf vargs ty (Event_call cp cp' i vl :: nil). + + Inductive return_trace_vr {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> val -> rettype -> trace -> Prop := + return_trace_vr_intra : forall (cp cp' : compartment) (v : val) (ty : rettype), + Genv.type_of_call ge cp cp' <> Genv.CrossCompartmentCall -> return_trace_vr ge cp cp' v ty E0 + | return_trace_vr_virtual : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype), + Genv.type_of_call ge cp cp' = Genv.DefaultCompartmentCall -> (res = typ_to_eventval (proj_rettype ty)) -> return_trace_vr ge cp cp' v ty (Event_return cp cp' res :: nil) + | return_trace_vr_cross : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype), + Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> eventval_match ge res (proj_rettype ty) v -> return_trace_vr ge cp cp' v ty (Event_return cp cp' res :: nil). + Variant asm_istep: state -> itrace -> state -> Prop := | exec_asm_istep_internal: forall b ofs f i rs m rs' m' b' ofs' st cp, @@ -378,16 +441,20 @@ Section ASMISTEP. 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), - forall (INFO: let ce := match (Genv.find_funct_ptr ge b', Genv.type_of_call ge (comp_of f) (Genv.find_comp_ignore_offset ge (Vptr b' ofs'))) with - | (Some (External ef), Genv.CrossCompartmentCall) => is_cross_ext + forall (EV: call_trace_vr ge (comp_of f) (Genv.find_comp_ignore_offset ge (Vptr b' ofs')) (Vptr b' ofs') + args (sig_args sig) t), + forall (INFO: let ce := match (Genv.find_funct_ptr ge b', (comp_of f) =? (Genv.find_comp_ignore_offset ge (Vptr b' ofs'))) with + | (Some (External ef), false) => is_cross_ext | _ => not_cross_ext end in - it = map (fun e => (e, info_call ce sig)) t), - forall (CROSS_SIG: 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 /\ Asm.funsig fd = sig) - ), + let vr := match Genv.type_of_call ge (comp_of f) (Genv.find_comp_ignore_offset ge (Vptr b' ofs')) with + | Genv.DefaultCompartmentCall => is_virtual + | _ => is_real + end in + it = map (fun e => (e, info_call ce sig vr)) t), + forall (CALLSIG: Genv.type_of_call ge (comp_of f) (Genv.find_comp_ignore_offset ge (Vptr b' ofs')) <> Genv.InternalCall -> + (exists fd, Genv.find_funct_ptr ge b' = Some fd /\ sig = Asm.funsig fd)), + forall (CPEQ: cp = (comp_of f)), asm_istep (State st rs m) it (State st' rs' m') | exec_asm_istep_internal_return: forall b ofs f i rs m rs' cp m' st, @@ -422,10 +489,14 @@ Section ASMISTEP. 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), - forall (INFO: it = map (fun e => (e, info_return sg)) t), + forall (EV: return_trace_vr ge cp' rec_cp (return_value rs sg) (sig_res sg) t), + forall (INFO: let vr := match Genv.type_of_call ge cp' rec_cp with + | Genv.DefaultCompartmentCall => is_virtual + | _ => is_real + end in + it = map (fun e => (e, info_return sg vr)) t), asm_istep (ReturnState st rs m) it (State st' rs m) - | exec_asm_istep_builtin: + | exec_asm_istep_builtin: forall b ofs f ef args res rs m vargs t vres rs' m' st it, rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal f) -> @@ -477,40 +548,124 @@ Section ASMITR. - exists (it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. { econstructor 1; eauto. simpl. rewrite ALLOWED in H3. unfold Genv.find_comp_ignore_offset in H3. auto. } auto. - - pose proof EV as EV0. inv EV0. - + exists (it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 2; eauto. admit. } + - pose proof EV as EV0. + destruct (Genv.type_of_call (Genv.globalenv p) (comp_of f) (Genv.find_comp_ignore_offset (Genv.globalenv p) (Vptr b' ofs'))) eqn:CCASES. + + inv EV0. 2: rewrite CCASES in H; inv H. + exists (it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. + { econstructor 2; eauto. + - simpl. setoid_rewrite CCASES. intros F; inv F. + - econstructor 1. auto. + - simpl. setoid_rewrite CCASES. intros F; contradiction F. auto. + - simpl. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H1. auto. + } auto. - + assert (CASES: (exists ef, Genv.find_funct_ptr (Genv.globalenv p) b' = Some (External ef)) \/ + + inv EV0. rewrite CCASES in H. congruence with H. + assert (CASES: (exists ef, Genv.find_funct_ptr (Genv.globalenv p) b' = Some (External ef)) \/ ((exists intf, Genv.find_funct_ptr (Genv.globalenv p) b' = Some (Internal intf)) \/ (Genv.find_funct_ptr (Genv.globalenv p) b' = None))). { destruct (Genv.find_funct_ptr (Genv.globalenv p) b') eqn:CASES; [|auto]. destruct f0; eauto. } destruct CASES as [EXT | ELSE]. - * exists ((Event_call (comp_of f) (Genv.find_comp_ignore_offset (Genv.globalenv p) (Vptr b' ofs')) i0 vl, info_call is_cross_ext sig) :: it). simpl. split; [|auto]. + * exists ((Event_call (comp_of f) (Genv.find_comp_ignore_offset (Genv.globalenv p) (Vptr b' ofs')) i0 vl, info_call is_cross_ext sig is_real) :: it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 2; eauto. admit. } - simpl. destruct EXT. rewrite H8. unfold Genv.find_comp_ignore_offset in H. rewrite H. auto. - * exists ((Event_call (comp_of f) (Genv.find_comp_ignore_offset (Genv.globalenv p) (Vptr b' ofs')) i0 vl, info_call not_cross_ext sig) :: it). simpl. split; [|auto]. + { econstructor 2; eauto. + - simpl. econstructor 3; eauto. + - admit. (* signature *) + - simpl. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H1. auto. + } + simpl. destruct EXT. rewrite H8. unfold Genv.find_comp_ignore_offset in H. rewrite H. + clear - H. unfold Genv.type_of_call in H. destruct (comp_of f =? Genv.find_comp (Genv.globalenv p) (Vptr b' Ptrofs.zero)). inv H. auto. + * exists ((Event_call (comp_of f) (Genv.find_comp_ignore_offset (Genv.globalenv p) (Vptr b' ofs')) i0 vl, info_call not_cross_ext sig is_real) :: it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 2; eauto. admit. } - simpl. destruct ELSE. destruct H8. rewrite H8. auto. rewrite H8. auto. + { econstructor 2; eauto. + - simpl. econstructor 3; eauto. + - admit. (* signature *) + - simpl. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H1. auto. + } + simpl. unfold Genv.find_comp_ignore_offset in H. rewrite H. destruct ELSE. destruct H8. rewrite H8. auto. rewrite H8. auto. + + inv EV0. + 2:{ rewrite CCASES in H. inv H. } + assert (CASES: (exists ef, Genv.find_funct_ptr (Genv.globalenv p) b' = Some (External ef)) \/ + ((exists intf, Genv.find_funct_ptr (Genv.globalenv p) b' = Some (Internal intf)) \/ (Genv.find_funct_ptr (Genv.globalenv p) b' = None))). + { destruct (Genv.find_funct_ptr (Genv.globalenv p) b') eqn:CASES; [|auto]. destruct f0; eauto. } + destruct (Genv.invert_symbol (Genv.globalenv p) b') eqn:SYMB. + 2:{ destruct CASES as [EXT | ELSE]. + * exists ((Event_call (comp_of f) (Genv.find_comp_ignore_offset (Genv.globalenv p) (Vptr b' ofs')) xH (typ_to_eventvals (sig_args sig)), info_call is_cross_ext sig is_virtual) :: it). simpl. split; [|auto]. + exists s2'. econstructor 2. 2: eapply ISTAR. + { econstructor 2; eauto. + - setoid_rewrite CCASES. intros F; inv F. + - simpl. econstructor 2; eauto. + - admit. (* signature *) + - simpl. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H1. auto. + } + simpl. destruct EXT. rewrite H5. unfold Genv.find_comp_ignore_offset in CCASES. rewrite CCASES. + unfold genv_invert_symbol_total. rewrite SYMB. + clear - CCASES. unfold Genv.type_of_call in CCASES. destruct (comp_of f =? Genv.find_comp (Genv.globalenv p) (Vptr b' Ptrofs.zero)); auto. inv CCASES. + * exists ((Event_call (comp_of f) (Genv.find_comp_ignore_offset (Genv.globalenv p) (Vptr b' ofs')) xH (typ_to_eventvals (sig_args sig)), info_call not_cross_ext sig is_virtual) :: it). simpl. split; [|auto]. + exists s2'. econstructor 2. 2: eapply ISTAR. + { econstructor 2; eauto. + - setoid_rewrite CCASES. intros F; inv F. + - simpl. econstructor 2; eauto. + - admit. (* signature *) + - simpl. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H1. auto. + } + simpl. unfold Genv.find_comp_ignore_offset in CCASES. rewrite CCASES. unfold genv_invert_symbol_total. rewrite SYMB. destruct ELSE. + destruct H5; rewrite H5. auto. rewrite H5. auto. + } + destruct CASES as [EXT | ELSE]. + * exists ((Event_call (comp_of f) (Genv.find_comp_ignore_offset (Genv.globalenv p) (Vptr b' ofs')) i0 (typ_to_eventvals (sig_args sig)), info_call is_cross_ext sig is_virtual) :: it). simpl. split; [|auto]. + exists s2'. econstructor 2. 2: eapply ISTAR. + { econstructor 2; eauto. + - setoid_rewrite CCASES. intros F; inv F. + - simpl. econstructor 2; eauto. + - admit. (* signature *) + - simpl. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H1. auto. + } + simpl. destruct EXT. rewrite H5. unfold Genv.find_comp_ignore_offset in CCASES. rewrite CCASES. + unfold genv_invert_symbol_total. rewrite SYMB. + clear - CCASES. unfold Genv.type_of_call in CCASES. destruct (comp_of f =? Genv.find_comp (Genv.globalenv p) (Vptr b' Ptrofs.zero)); auto. inv CCASES. + * exists ((Event_call (comp_of f) (Genv.find_comp_ignore_offset (Genv.globalenv p) (Vptr b' ofs')) i0 (typ_to_eventvals (sig_args sig)), info_call not_cross_ext sig is_virtual) :: it). simpl. split; [|auto]. + exists s2'. econstructor 2. 2: eapply ISTAR. + { econstructor 2; eauto. + - setoid_rewrite CCASES. intros F; inv F. + - simpl. econstructor 2; eauto. + - admit. (* signature *) + - simpl. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H1. auto. + } + simpl. unfold Genv.find_comp_ignore_offset in CCASES. rewrite CCASES. unfold genv_invert_symbol_total. rewrite SYMB. destruct ELSE. + destruct H5; rewrite H5. auto. rewrite H5. auto. - exists (it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. { econstructor 3; eauto. } auto. - - pose proof EV as EV0. inv EV0. - + exists (it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 4; eauto. } + - pose proof EV as EV0. + destruct (Genv.type_of_call (Genv.globalenv p) (Genv.find_comp_ignore_offset (Genv.globalenv p) (rs PC)) (callee_comp (comp_of_main p) st)) eqn:CCASES. + + inv EV0. + 2:{ rewrite CCASES in H. inv H. } + exists (it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. + { econstructor 4; eauto. + - simpl. rewrite CCASES. intros F; inv F. + - econstructor 1; auto. + } auto. - + exists ((Event_return (Genv.find_comp_ignore_offset (Genv.globalenv p) (rs PC)) (callee_comp (comp_of_main p) st) res, info_return (sig_of_call st)) :: it). + + inv EV0. rewrite CCASES in H. congruence with H. + exists ((Event_return (Genv.find_comp_ignore_offset (Genv.globalenv p) (rs PC)) (callee_comp (comp_of_main p) st) res, info_return (sig_of_call st) is_real) :: it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 4; eauto. } - auto. + { econstructor 4; eauto. econstructor 3; eauto. } + simpl. rewrite CCASES. auto. + + inv EV0. + 2:{ rewrite CCASES in H. inv H. } + exists ((Event_return (Genv.find_comp_ignore_offset (Genv.globalenv p) (rs PC)) (callee_comp (comp_of_main p) st) (typ_to_eventval (proj_rettype (sig_res (sig_of_call st)))), info_return (sig_of_call st) is_virtual) :: it). + simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. + { econstructor 4; eauto. + - simpl. rewrite CCASES. intros F; inv F. + - econstructor 2; eauto. + } + simpl. rewrite CCASES. auto. - exists ((map (fun e => (e, info_builtin ef)) t1) ++ it). simpl; split. - 2:{ unfold itr_to_tr. rewrite map_app. unfold Eapp. f_equal. rewrite map_map. simpl. apply map_id. } + 2:{ rewrite itr_to_tr_app. unfold Eapp. f_equal. unfold itr_to_tr. rewrite filter_map; simpl; auto. rewrite map_map. simpl. apply map_id. } exists s2'. econstructor 2. 2: eapply ISTAR. { econstructor 5; eauto. } auto. - exists ((map (fun e => (e, info_external b (ef_sig ef))) t1) ++ it). simpl; split. - 2:{ unfold itr_to_tr. rewrite map_app. unfold Eapp. f_equal. rewrite map_map. simpl. apply map_id. } + 2:{ rewrite itr_to_tr_app. unfold Eapp. f_equal. unfold itr_to_tr. rewrite filter_map; simpl; auto. rewrite map_map. simpl. apply map_id. } exists s2'. econstructor 2. 2: eapply ISTAR. { econstructor 6; eauto. } auto. From ce5592c82958d32c4fc45d075d8b185ae1cc401f Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 15 May 2023 20:53:47 +0200 Subject: [PATCH 052/174] WIP --- security/BtFromAsm.v | 280 +++++++++---------------------------------- security/BtInfoAsm.v | 2 +- 2 files changed, 58 insertions(+), 224 deletions(-) diff --git a/security/BtFromAsm.v b/security/BtFromAsm.v index 6a752b7cc6..0e83145a7d 100644 --- a/security/BtFromAsm.v +++ b/security/BtFromAsm.v @@ -14,6 +14,16 @@ Section WELLFORMED. Variant sf_cont_type : Type := | sf_cont: block -> sf_cont_type. Definition sf_conts := list sf_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 virtual_reality (ct: Genv.call_type) (vr: real_virtual): Prop := + match ct with + | Genv.InternalCall => False + | Genv.CrossCompartmentCall => vr = is_real + | Genv.DefaultCompartmentCall => vr = is_virtual + end. + (* wf_sem: from asm, wf_st: proof invariant for Clight states *) Inductive info_asm_sem_wf (ge: Asm.genv) : block -> mem -> sf_conts -> itrace -> Prop := | info_asm_sem_wf_base @@ -21,43 +31,44 @@ Section WELLFORMED. : info_asm_sem_wf ge cur m1 sf nil | info_asm_sem_wf_cross_call - cur m1 sf ev ik tl + cur m1 sf ev ik vr tl cp (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) cp' fid evargs (EV: ev = Event_call cp cp' fid evargs) sg - (IK: ik = info_call not_cross_ext sg) + (IK: ik = info_call not_cross_ext sg vr) b (FINDB: Genv.find_symbol ge fid = Some b) fd (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) (CP': cp' = comp_of fd) - (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) + (VR: virtual_reality (Genv.type_of_call ge cp cp') vr) + (* (CROSS: Genv.type_of_call ge cp cp' <> Genv.InternalCall) *) args - (NPTR: Forall not_ptr args) - (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) - (ESM: eventval_list_match ge evargs (sig_args sg) args) + (NPTR: crossing_comp ge cp cp' -> Forall not_ptr args) + (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) + (ESM: crossing_comp ge cp cp' -> eventval_list_match ge evargs (sig_args sg) args) (SIG: sg = Asm.funsig fd) (NEXT: info_asm_sem_wf ge b m1 ((sf_cont cur) :: sf) tl) : info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) | info_asm_sem_wf_cross_return_internal - cur m1 ev ik tl + cur m1 ev ik vr tl cp (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) cp_c evres (EV: ev = Event_return cp_c cp evres) sg - (IK: ik = info_return sg) + (IK: ik = info_return sg vr) cur_f (INTERNAL: Genv.find_funct_ptr ge cur = Some (AST.Internal cur_f)) (* Follows from cross call - stack has the sig *) (SIG: sg = Asm.fn_sig cur_f) - (CROSS: Genv.type_of_call ge cp_c cp = Genv.CrossCompartmentCall) + (VR: virtual_reality (Genv.type_of_call ge cp_c cp) vr) res - (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) res) - (NPTR: not_ptr res) + (EVM: crossing_comp ge cp_c cp -> eventval_match ge evres (proj_rettype (sig_res sg)) res) + (NPTR: crossing_comp ge cp_c cp -> not_ptr res) b_c sf_tl (CPC: cp_c = Genv.find_comp ge (Vptr b_c Ptrofs.zero)) (* internal return: memory changes in Clight-side, so need inj-relation *) @@ -76,7 +87,7 @@ Section WELLFORMED. (INV: Genv.invert_symbol ge fb = Some fid) (ISEXT: Genv.find_funct_ptr ge fb = Some (AST.External ef)) (ALLOWED: Genv.allowed_call ge cp (Vptr fb Ptrofs.zero)) - (INTRA: Genv.type_of_call ge cp (Genv.find_comp ge (Vptr fb Ptrofs.zero)) <> Genv.CrossCompartmentCall) + (INTRA: Genv.type_of_call ge cp (Genv.find_comp ge (Vptr fb Ptrofs.zero)) = Genv.InternalCall) (NEXT: info_asm_sem_wf ge cur m2 sf tl) : info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) @@ -92,23 +103,23 @@ Section WELLFORMED. info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) | info_asm_sem_wf_cross_call_external1 (* early cut at call event *) - cur m1 sf ev ik + cur m1 sf ev vr ik cp (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) cp' fid evargs (EV: ev = Event_call cp cp' fid evargs) sg - (IK: ik = info_call is_cross_ext sg) + (IK: ik = info_call is_cross_ext sg vr) b (FINDB: Genv.find_symbol ge fid = Some b) fd (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) (CP': cp' = comp_of fd) - (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) + (VR: virtual_reality (Genv.type_of_call ge cp cp') vr) args - (NPTR: Forall not_ptr args) - (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) - (ESM: eventval_list_match ge evargs (sig_args sg) args) + (NPTR: crossing_comp ge cp cp' -> Forall not_ptr args) + (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) + (ESM: crossing_comp ge cp cp' -> eventval_list_match ge evargs (sig_args sg) args) ef (EXTERNAL: fd = AST.External ef) (SIG: sg = ef_sig ef) @@ -116,23 +127,23 @@ Section WELLFORMED. info_asm_sem_wf ge cur m1 sf ((ev, ik) :: nil) | info_asm_sem_wf_cross_call_external2 (* early cut at call-ext_call event *) - cur m1 sf ev1 ik1 + cur m1 sf ev1 vr1 ik1 cp (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) cp' fid evargs (EV: ev1 = Event_call cp cp' fid evargs) sg - (IK: ik1 = info_call is_cross_ext sg) + (IK: ik1 = info_call is_cross_ext sg vr1) b (FINDB: Genv.find_symbol ge fid = Some b) fd (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) (CP': cp' = comp_of fd) - (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) + (VR: virtual_reality (Genv.type_of_call ge cp cp') vr1) args - (NPTR: Forall not_ptr args) - (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) - (ESM: eventval_list_match ge evargs (sig_args sg) args) + (NPTR: crossing_comp ge cp cp' -> Forall not_ptr args) + (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) + (ESM: crossing_comp ge cp cp' -> eventval_list_match ge evargs (sig_args sg) args) ef (EXTERNAL: fd = AST.External ef) (SIG: sg = ef_sig ef) @@ -145,23 +156,23 @@ Section WELLFORMED. info_asm_sem_wf ge cur m1 sf ((ev1, ik1) :: itr) | info_asm_sem_wf_cross_call_external3 (* full call-ext_call-return event *) - cur m1 sf ev1 ik1 + cur m1 sf ev1 vr1 ik1 cp (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) cp' fid evargs (EV: ev1 = Event_call cp cp' fid evargs) sg - (IK: ik1 = info_call is_cross_ext sg) + (IK: ik1 = info_call is_cross_ext sg vr1) b (FINDB: Genv.find_symbol ge fid = Some b) fd (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) (CP': cp' = comp_of fd) - (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) + (VR1: virtual_reality (Genv.type_of_call ge cp cp') vr1) args - (NPTR: Forall not_ptr args) - (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) - (ESM: eventval_list_match ge evargs (sig_args sg) args) + (NPTR: crossing_comp ge cp cp' -> Forall not_ptr args) + (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) + (ESM: crossing_comp ge cp cp' -> eventval_list_match ge evargs (sig_args sg) args) ef (EXTERNAL: fd = AST.External ef) (SIG: sg = ef_sig ef) @@ -171,197 +182,19 @@ Section WELLFORMED. itr (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) (* return part *) - ev3 ik3 tl + ev3 vr3 ik3 tl evres (EV: ev3 = Event_return cp cp' evres) sg - (IK: ik3 = info_return sg) - (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) vres) - (NPTR: not_ptr vres) + (IK: ik3 = info_return sg vr3) + (VR2: virtual_reality (Genv.type_of_call ge cp cp') vr3) + (EVM: crossing_comp ge cp cp' -> eventval_match ge evres (proj_rettype (sig_res sg)) vres) + (NPTR: crossing_comp ge cp cp' -> not_ptr vres) (NEXT: info_asm_sem_wf ge cur m2 sf tl) : info_asm_sem_wf ge cur m1 sf ((ev1, ik1) :: (itr ++ ((ev3, ik3) :: tl))) . - (* Inductive info_asm_sem_wf (ge: Asm.genv) : block -> mem -> sf_conts -> itrace -> Prop := *) - (* | info_asm_sem_wf_base *) - (* cur m1 sf *) - (* : *) - (* info_asm_sem_wf ge cur m1 sf nil *) - (* | info_asm_sem_wf_cross_call_internal *) - (* cur m1 sf ev ik tl *) - (* cp *) - (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) - (* cp' fid evargs *) - (* (EV: ev = Event_call cp cp' fid evargs) *) - (* sg *) - (* (IK: ik = info_call not_cross_ext sg) *) - (* b *) - (* (FINDB: Genv.find_symbol ge fid = Some b) *) - (* fd *) - (* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) *) - (* (CP': cp' = comp_of fd) *) - (* (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) *) - (* args *) - (* (NPTR: Forall not_ptr args) *) - (* (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) *) - (* (ESM: eventval_list_match ge evargs (sig_args sg) args) *) - (* callee_f *) - (* (INTERNAL: fd = AST.Internal callee_f) *) - (* (* TODO: separate this; *) - (* might be better to upgrade Asm semantics to actually refer to its fn_sig. *) - (* Note that it's not possible to recover Clight fun type data from trace since *) - (* there can be conflicts, since Asm semantics actually allows non-fixed sigs. *) - (* *) *) - (* (SIG: sg = Asm.fn_sig callee_f) *) - (* (* internal call: memory changes in Clight-side, so need inj-relation *) *) - (* (NEXT: info_asm_sem_wf ge b m1 ((sf_cont cur) :: sf) tl) *) - (* : *) - (* info_asm_sem_wf ge ir_internal cur m1 sf ((ev, ik) :: tl) *) - (* | info_asm_sem_wf_cross_return_internal *) - (* cur m1 ev ik tl *) - (* cp *) - (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) - (* cp_c evres *) - (* (EV: ev = Event_return cp_c cp evres) *) - (* sg *) - (* (IK: ik = info_return sg) *) - (* cur_f *) - (* (INTERNAL: Genv.find_funct_ptr ge cur = Some (AST.Internal cur_f)) *) - (* (* TODO: separate this *) *) - (* (SIG: sg = Asm.fn_sig cur_f) *) - (* (CROSS: Genv.type_of_call ge cp_c cp = Genv.CrossCompartmentCall) *) - (* res *) - (* (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) res) *) - (* (NPTR: not_ptr res) *) - (* b_c sf_tl *) - (* (CPC: cp_c = Genv.find_comp ge (Vptr b_c Ptrofs.zero)) *) - (* (* internal return: memory changes in Clight-side, so need inj-relation *) *) - (* (NEXT: info_asm_sem_wf ge b_c m1 sf_tl tl) *) - (* : *) - (* info_asm_sem_wf ge cur m1 ((sf_cont b_c) :: sf_tl) ((ev, ik) :: tl) *) - (* | info_asm_sem_wf_intra_call_external *) - (* cur m1 sf ev ik tl *) - (* cp *) - (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) - (* ef res m2 *) - (* (EXTEV: external_call_event_match_common ef ev ge cp m1 res m2) *) - (* fb *) - (* (IK: ik = info_external fb (ef_sig ef)) *) - (* fid *) - (* (INV: Genv.invert_symbol ge fb = Some fid) *) - (* (ISEXT: Genv.find_funct_ptr ge fb = Some (AST.External ef)) *) - (* (ALLOWED: Genv.allowed_call ge cp (Vptr fb Ptrofs.zero)) *) - (* (INTRA: Genv.type_of_call ge cp (Genv.find_comp ge (Vptr fb Ptrofs.zero)) <> Genv.CrossCompartmentCall) *) - (* (NEXT: info_asm_sem_wf ge cur m2 sf tl) *) - (* : *) - (* info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) *) - (* | info_asm_sem_wf_builtin *) - (* cur m1 sf ev ik tl *) - (* cp *) - (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) - (* ef res m2 *) - (* (EXT: external_call_event_match_common ef ev ge cp m1 res m2) *) - (* (IK: ik = info_builtin ef) *) - (* (NEXT: info_asm_sem_wf ge cur m2 sf tl) *) - (* : *) - (* info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) *) - (* | info_asm_sem_wf_cross_call_external1 *) - (* (* early cut at call event *) *) - (* cur m1 sf ev ik *) - (* cp *) - (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) - (* cp' fid evargs *) - (* (EV: ev = Event_call cp cp' fid evargs) *) - (* sg *) - (* (IK: ik = info_call is_cross_ext sg) *) - (* b *) - (* (FINDB: Genv.find_symbol ge fid = Some b) *) - (* fd *) - (* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) *) - (* (CP': cp' = comp_of fd) *) - (* (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) *) - (* args *) - (* (NPTR: Forall not_ptr args) *) - (* (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) *) - (* (ESM: eventval_list_match ge evargs (sig_args sg) args) *) - (* ef *) - (* (EXTERNAL: fd = AST.External ef) *) - (* (* TODO: separate this *) *) - (* (SIG: sg = ef_sig ef) *) - (* : *) - (* info_asm_sem_wf ge cur m1 sf ((ev, ik) :: nil) *) - (* | info_asm_sem_wf_cross_call_external2 *) - (* (* early cut at call-ext_call event *) *) - (* cur m1 sf ev1 ik1 *) - (* cp *) - (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) - (* cp' fid evargs *) - (* (EV: ev1 = Event_call cp cp' fid evargs) *) - (* sg *) - (* (IK: ik1 = info_call is_cross_ext sg) *) - (* b *) - (* (FINDB: Genv.find_symbol ge fid = Some b) *) - (* fd *) - (* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) *) - (* (CP': cp' = comp_of fd) *) - (* (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) *) - (* args *) - (* (NPTR: Forall not_ptr args) *) - (* (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) *) - (* (ESM: eventval_list_match ge evargs (sig_args sg) args) *) - (* ef *) - (* (EXTERNAL: fd = AST.External ef) *) - (* (* TODO: separate this *) *) - (* (SIG: sg = ef_sig ef) *) - (* (* external call part *) *) - (* tr vres m2 *) - (* (EXTCALL: external_call ef ge cp args m1 tr vres m2) *) - (* itr *) - (* (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) *) - (* : *) - (* info_asm_sem_wf ge cur m1 sf ((ev1, ik1) :: itr) *) - (* | info_asm_sem_wf_cross_call_external3 *) - (* (* full call-ext_call-return event *) *) - (* cur m1 sf ev1 ik1 *) - (* cp *) - (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) - (* cp' fid evargs *) - (* (EV: ev1 = Event_call cp cp' fid evargs) *) - (* sg *) - (* (IK: ik1 = info_call is_cross_ext sg) *) - (* b *) - (* (FINDB: Genv.find_symbol ge fid = Some b) *) - (* fd *) - (* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) *) - (* (CP': cp' = comp_of fd) *) - (* (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) *) - (* args *) - (* (NPTR: Forall not_ptr args) *) - (* (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) *) - (* (ESM: eventval_list_match ge evargs (sig_args sg) args) *) - (* ef *) - (* (EXTERNAL: fd = AST.External ef) *) - (* (* TODO: separate this *) *) - (* (SIG: sg = ef_sig ef) *) - (* (* external call part *) *) - (* tr vres m2 *) - (* (EXTCALL: external_call ef ge cp args m1 tr vres m2) *) - (* itr *) - (* (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) *) - (* (* return part *) *) - (* ev3 ik3 tl *) - (* evres *) - (* (EV: ev3 = Event_return cp cp' evres) *) - (* sg *) - (* (IK: ik3 = info_return sg) *) - (* (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) vres) *) - (* (NPTR: not_ptr vres) *) - (* (NEXT: info_asm_sem_wf ge cur m2 sf tl) *) - (* : *) - (* info_asm_sem_wf ge cur m1 sf ((ev1, ik1) :: (itr ++ ((ev3, ik3) :: tl))) *) - (* . *) - (* TODO *) (* we need a more precise invariant for the proof; counters, mem_inj, env, cont, state *) @@ -494,7 +327,6 @@ Section PROOF. move n before ge. revert s s' it WFGE STAR sk rs m STATE WFSK WFRS cur m_ir k MC MM MS. pattern n. apply (well_founded_induction Nat.lt_wf_0). intros m IH. intros. inv STAR; subst. - (* remember (asm_istep cpm) as istep. revert dependent cpm. revert sk rs m STATE WFSK cur m_ir k MC MM MS. induction STAR; intros; subst. *) { constructor 1. } rename H0 into STAR. inv H; simpl. - assert (INTRA: Genv.find_comp ge (Vptr cur Ptrofs.zero) = Genv.find_comp_ignore_offset ge (rs' PC)). @@ -510,24 +342,26 @@ Section PROOF. inv H0. { exploit external_call_trace_length. eauto. intros EVLEN. destruct t. - simpl. constructor 1. - - destruct t; simpl in EVLEN. 2: lia. + - destruct t; simpl in EVLEN. 2: lia. clear EVLEN. simpl. pose proof NEXTFUN as NF0. unfold Genv.find_funct_ptr in NF0. destruct (Genv.find_def ge b0) eqn:FDB0; [|inv NF0]. destruct g; inv NF0. exploit wf_ge_block_to_id; eauto. intros (fid & INV). econstructor 4; try reflexivity; auto. { admit. (* ext call sem *) } { eauto. } { unfold Genv.allowed_call. right; left. rewrite <- NEXTPC. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. auto. } - { unfold Genv.type_of_call. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. rewrite Pos.eqb_refl. intros F. inv F. } + { unfold Genv.type_of_call. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. rewrite Pos.eqb_refl. auto. } { constructor 1. } } inv H; simpl in *. - exploit external_call_trace_length. eauto. intros EVLEN. destruct t. - { simpl. pose proof EV as RETEV. inv RETEV; simpl. - { eapply IH. 3: eauto. all: auto. - assert (STEQ: st' = sk). - - { unfold update_stack_return in STUPD. - econstructor 4. + destruct (Pos.eqb_spec (callee_comp cpm sk) (Genv.find_comp_ignore_offset ge ((set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (rs' X1) PC))). + (* TODO *) + { exploit external_call_trace_length. eauto. intros EVLEN. destruct t. + { simpl. clear EVLEN. pose proof EV as RETEV. inv RETEV; simpl. + { eapply IH. 3: eauto. all: auto. + assert (STEQ: st' = sk). + + { unfold update_stack_return in STUPD. + econstructor 4. (* TODO *) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 2c9e08f3bd..3c3621472f 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -405,7 +405,7 @@ Section ASMISTEP. Inductive return_trace_vr {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> val -> rettype -> trace -> Prop := return_trace_vr_intra : forall (cp cp' : compartment) (v : val) (ty : rettype), - Genv.type_of_call ge cp cp' <> Genv.CrossCompartmentCall -> return_trace_vr ge cp cp' v ty E0 + Genv.type_of_call ge cp cp' = Genv.InternalCall -> return_trace_vr ge cp cp' v ty E0 | return_trace_vr_virtual : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype), Genv.type_of_call ge cp cp' = Genv.DefaultCompartmentCall -> (res = typ_to_eventval (proj_rettype ty)) -> return_trace_vr ge cp cp' v ty (Event_return cp cp' res :: nil) | return_trace_vr_cross : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype), From 2534c82b4c0fb581e7e00b62cf912b76895c0c03 Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 16 May 2023 16:33:00 +0200 Subject: [PATCH 053/174] WIP --- security/BtFromAsm.v | 113 +++++++++++++++++++++++++++++++++++-------- 1 file changed, 92 insertions(+), 21 deletions(-) diff --git a/security/BtFromAsm.v b/security/BtFromAsm.v index 0e83145a7d..e813d7e1e5 100644 --- a/security/BtFromAsm.v +++ b/security/BtFromAsm.v @@ -233,28 +233,26 @@ Section MATCH. end. Definition wf_stack (ge: Asm.genv) (sk: stack) := Forall (wf_stackframe ge) sk. - Definition wf_regset_stack cpm (ge: Asm.genv) (rs: regset) (sk: stack) := + Definition wf_regset_stack (ge: Asm.genv) (rs: regset) := match rs PC with | Vptr b _ => match Genv.find_funct_ptr ge b with - | Some (External ef) => Genv.find_comp_ignore_offset ge (rs RA) = callee_comp cpm sk + | Some (External ef) => False | _ => True end | _ => True end. - (* Definition wf_state cpm (ge: Asm.genv) (s: state) := *) - (* match s with *) - (* | State sk rs m => match rs PC with *) - (* | Vptr b _ => match Genv.find_funct_ptr ge b with *) - (* | Some (External ef) => Genv.find_comp_ignore_offset ge (rs RA) = callee_comp cpm sk *) - (* | _ => True *) - (* end *) - (* | _ => True *) - (* end *) - (* | _ => False *) + (* Definition wf_regset_stack cpm (ge: Asm.genv) (rs: regset) (sk: stack) := *) + (* match rs PC with *) + (* | Vptr b _ => match Genv.find_funct_ptr ge b with *) + (* | Some (External ef) => Genv.find_comp_ignore_offset ge (rs RA) = callee_comp cpm sk *) + (* | _ => True *) + (* end *) + (* | _ => True *) (* end. *) + (* Definition external_call_mem_inject_gen ef := ec_mem_inject (external_call_spec ef). *) (* external_call_mem_inject: *) @@ -307,6 +305,12 @@ Section PROOF. 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. + (* If main is External, treat it in a different case - the trace can start with Event_syscall, without a preceding Event_call *) Lemma from_info_asm_sem_wf cpm ge s s' it @@ -315,7 +319,8 @@ Section PROOF. sk rs m (STATE: s = State sk rs m) (WFSK: wf_stack ge sk) - (WFRS: wf_regset_stack cpm ge rs sk) + (WFRS: wf_regset_stack ge rs) + (* (WFRS: wf_regset_stack cpm ge rs sk) *) cur m_ir k (MC: match_cp ge cur (Genv.find_comp_ignore_offset ge (rs PC))) (MM: match_mem ge m_ir m) @@ -335,12 +340,13 @@ Section PROOF. + eapply IH; try reflexivity. 3: eauto. all: auto. { unfold wf_regset_stack. rewrite NEXTPC, NEXTFUN. auto. } { admit. (* mem *) } - + inv STAR. + + (* intra -> external *) + inv STAR. { constructor 1. } - inv H. - all: rewrite NEXTPC in H8; inv H8; rewrite NEXTFUN in H11; inv H11. + inv H. all: rewrite NEXTPC in H8; inv H8; rewrite NEXTFUN in H11; inv H11. inv H0. - { exploit external_call_trace_length. eauto. intros EVLEN. destruct t. + { (* trace ends *) + exploit external_call_trace_length. eauto. intros EVLEN. destruct t. - simpl. constructor 1. - destruct t; simpl in EVLEN. 2: lia. clear EVLEN. simpl. pose proof NEXTFUN as NF0. unfold Genv.find_funct_ptr in NF0. destruct (Genv.find_def ge b0) eqn:FDB0; [|inv NF0]. destruct g; inv NF0. @@ -352,11 +358,76 @@ Section PROOF. { unfold Genv.type_of_call. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. rewrite Pos.eqb_refl. auto. } { constructor 1. } } - inv H; simpl in *. + inv H. + (* replace ((set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (rs' X1) PC) with (rs' X1) in *. *) + (* 2:{ rewrite Pregmap.gss. auto. } *) destruct (Pos.eqb_spec (callee_comp cpm sk) (Genv.find_comp_ignore_offset ge ((set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (rs' X1) PC))). - (* TODO *) - { exploit external_call_trace_length. eauto. intros EVLEN. destruct t. - { simpl. clear EVLEN. pose proof EV as RETEV. inv RETEV; simpl. + { (* intra-return *) + clear PC_RA RESTORE_SP NO_CROSS_PTR. pose proof EV as RETEV. inv RETEV; simpl. + 2:{ exfalso. unfold Genv.type_of_call in H. rewrite <- e in H. rewrite Pos.eqb_refl in H. inv H. } + 2:{ exfalso. unfold Genv.type_of_call in H. rewrite <- e in H. rewrite Pos.eqb_refl in H. inv H. } + assert (STK: st' = sk). + { unfold update_stack_return in STUPD. rewrite <- e in STUPD. rewrite Pos.eqb_refl in STUPD. inv STUPD. auto. } + subst st'. simpl in INFO; subst. simpl. + pose proof H1 as IH_ISTAR. move IH_ISTAR after H1. inv H1. + { (* trace ends *) + exploit external_call_trace_length. eauto. intros EVLEN. destruct t. + { simpl. clear EVLEN. constructor 1. } + destruct t; simpl in EVLEN. 2: lia. clear EVLEN. + pose proof NEXTFUN as NF0. unfold Genv.find_funct_ptr in NF0. destruct (Genv.find_def ge b0) eqn:FDB0; [|inv NF0]. destruct g; inv NF0. + exploit wf_ge_block_to_id. eauto. eapply FDB0. intros (fid & INV). + eapply info_asm_sem_wf_intra_call_external; eauto. + { admit. (* ext call sem *) } + { unfold Genv.allowed_call. right; left. rewrite <- NEXTPC. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. auto. } + { unfold Genv.type_of_call. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. rewrite Pos.eqb_refl. auto. } + { constructor 1. } + } + (* now we case-analysis new PC = (rs' X1) *) + destruct (val_is_ptr_or_not (rs' X1)). + { (* not a Vptr, so booms for every step *) + rename H1 into NP. clear - H0 NP. inv H0; exfalso. all: rewrite Pregmap.gss in H3; eapply NP; eauto. + } + destruct H1 as (b2 & ofs2 & NEXTPC2). destruct (Genv.find_funct_ptr ge b2) eqn:NEXTFUN2. destruct f0. + { (* next fun is internal - done by induction *) + exploit external_call_trace_length. eauto. intros EVLEN. destruct t; simpl. + { clear EVLEN. eapply IH. 3: eapply IH_ISTAR. all: auto. + - red. rewrite Pregmap.gss. rewrite NEXTPC2. rewrite NEXTFUN2. auto. + - rewrite Pregmap.gss in *. rewrite <- e. rewrite <- REC_CURCOMP. auto. + - admit. (* mem *) + } + destruct t; simpl in *. 2:lia. clear EVLEN. + pose proof NEXTFUN as NF0. unfold Genv.find_funct_ptr in NF0. destruct (Genv.find_def ge b0) eqn:FDB0; [|inv NF0]. destruct g; inv NF0. + exploit wf_ge_block_to_id. eauto. eapply FDB0. intros (fid & INV). + eapply info_asm_sem_wf_intra_call_external; eauto. + { admit. (* ext call sem *) } + { unfold Genv.allowed_call. right; left. rewrite <- NEXTPC. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. auto. } + { unfold Genv.type_of_call. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. rewrite Pos.eqb_refl. auto. } + eapply IH. 3: eapply IH_ISTAR. all: auto. + - red. rewrite Pregmap.gss. rewrite NEXTPC2. rewrite NEXTFUN2. auto. + - rewrite Pregmap.gss in *. rewrite <- e. rewrite <- REC_CURCOMP. auto. + - admit. (* mem *) + } + { (* next fun is external; undef_caller_save_regs sets RA=Vundef, so we take extcall-step, which sets PC=RA, and after the return step, we have PC=Vundef. *) + + + + + + + constructor 1. } + + + + + + + + exploit external_call_trace_length. eauto. intros EVLEN. destruct t. + { simpl. clear EVLEN. eapply IH. 3: eapply H1. all: auto. + - red. rewrite Pregmap.gss. + (* TODO *) + + pose proof EV as RETEV. inv RETEV; simpl. { eapply IH. 3: eauto. all: auto. assert (STEQ: st' = sk). From 9e53032de7913106ed89edd2061964ee6fc485e7 Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 16 May 2023 18:39:43 +0200 Subject: [PATCH 054/174] WIP; extcall has a problem - without event, can change memory --- security/BtFromAsm.v | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/security/BtFromAsm.v b/security/BtFromAsm.v index e813d7e1e5..dbcae55aac 100644 --- a/security/BtFromAsm.v +++ b/security/BtFromAsm.v @@ -390,10 +390,11 @@ Section PROOF. destruct H1 as (b2 & ofs2 & NEXTPC2). destruct (Genv.find_funct_ptr ge b2) eqn:NEXTFUN2. destruct f0. { (* next fun is internal - done by induction *) exploit external_call_trace_length. eauto. intros EVLEN. destruct t; simpl. - { clear EVLEN. eapply IH. 3: eapply IH_ISTAR. all: auto. + { clear EVLEN. + eapply IH. 3: eapply IH_ISTAR. all: auto. - red. rewrite Pregmap.gss. rewrite NEXTPC2. rewrite NEXTFUN2. auto. - rewrite Pregmap.gss in *. rewrite <- e. rewrite <- REC_CURCOMP. auto. - - admit. (* mem *) + - admit. (* mem -> need to execute external call to maintain injection? *) } destruct t; simpl in *. 2:lia. clear EVLEN. pose proof NEXTFUN as NF0. unfold Genv.find_funct_ptr in NF0. destruct (Genv.find_def ge b0) eqn:FDB0; [|inv NF0]. destruct g; inv NF0. @@ -408,6 +409,7 @@ Section PROOF. - admit. (* mem *) } { (* next fun is external; undef_caller_save_regs sets RA=Vundef, so we take extcall-step, which sets PC=RA, and after the return step, we have PC=Vundef. *) + (* TODO *) From 15d18930f1af5cd945e3e2ea8b2190e126175b5e Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 18 May 2023 18:00:22 +0200 Subject: [PATCH 055/174] WIP; revising semantics --- security/BtInfoAsm.v | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 3c3621472f..66140b2ef6 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -366,6 +366,34 @@ Ltac itraceEq := (* End AUX. *) +Section AUX. + + Definition block_first_order (m: mem) (b: block): Prop := + forall (ofs: Z), + match (ZMap.get ofs (Mem.mem_contents m) !! b) with + | Fragment vv _ _ => not_ptr vv + | _ => True + end. + + (* Definition val_first_order (m: mem) (v: val): Prop := *) + (* match v with *) + (* | Vptr b _ => block_first_order m b *) + (* | _ => True *) + (* end. *) + + (* Redundant - we enforce Event_syscall to respect eventval_list_match on args, + which enforce pointers to be public - which are first-order by the semantics *) + (* Definition syscall_args_first_order (m: mem) (args: list val) := *) + (* Forall (val_first_order m) args. *) + + (* Public symbols are visible outside the compilation unit, + so when interacting via external calls, limit them to first-order. *) + Definition public_first_order (ge: Senv.t) (m: mem) := + forall id b (PUBLIC: Senv.public_symbol ge id = true) (FIND: Senv.find_symbol ge id = Some b), + block_first_order m b. + +End AUX. + Section ASMISTEP. Variable cpm: compartment. @@ -520,8 +548,11 @@ Section ASMISTEP. (* These steps behave like returns. So we do the same as in the [exec_asm_istep_internal_return] case. *) forall (REC_CURCOMP: Genv.find_comp_ignore_offset ge (rs PC) = callee_comp cpm st), forall (INFO: it = map (fun e => (e, info_external b (ef_sig ef))) t), + forall (PFO: public_first_order ge m), asm_istep (State st rs m) it (ReturnState st rs' m'). + (* TODO: fix all the semantics, add CALLSIG and PFO *) + End ASMISTEP. From b7cb91ee3749c402509aff45b2e55edb4dae8c13 Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 19 May 2023 15:35:19 +0200 Subject: [PATCH 056/174] WIP: define bundle event --- security/BtInfoAsm.v | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 66140b2ef6..d65182c0f6 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -8,6 +8,27 @@ Require Import riscV.Machregs. Require Import riscV.Asm. Require Import Complements. + +Section BUNDLE. + + (* ()-no event, {}-may event, when len(tr) > 1, need to consider cuts *) + (* intra/cross/virtual(default), internal/external *) + Variant bundle_event : Type := + (* generate a call code + others *) + | Bundle_call_ci (evs: trace) (* call *) + | Bundle_call_ce (cutat: nat) (evs: trace) (* call-{ext}-ret - cutat in {1, 2, 3} *) + | Bundle_call_vi (evs: trace) (* (call) - compartment changes *) + | Bundle_call_ve (evs: trace) (* (call)-ext-(ret) - call/ret cancels compartment change, so only consider when visible *) + | Bundle_call_ie (evs: trace) (* (call)-ext-(ret) *) + (* generate a return code *) + | Bundle_return_ci (evs: trace) (* ret *) + | Bundle_return_vi (evs: trace) (* (ret) - compartment change *) + (* generate a builtin code *) + | Bundle_builtin (evs: trace) (* ext *) + . + +End BUNDLE. + Section HASINIT. Import Smallstep. @@ -698,7 +719,9 @@ Section ASMITR. - exists ((map (fun e => (e, info_external b (ef_sig ef))) t1) ++ it). simpl; split. 2:{ rewrite itr_to_tr_app. unfold Eapp. f_equal. unfold itr_to_tr. rewrite filter_map; simpl; auto. rewrite map_map. simpl. apply map_id. } exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 6; eauto. } + { econstructor 6; eauto. + admit. (* public first order *) + } auto. Admitted. From 65df1cefa9a3c4e275d471b0bf3d12f5fee683ad Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 19 May 2023 17:59:26 +0200 Subject: [PATCH 057/174] WIP --- security/BtBasics.v | 120 +++++++++++++++++++++++++++++++++++++++++ security/BtInfoAsm.v | 123 +------------------------------------------ 2 files changed, 122 insertions(+), 121 deletions(-) diff --git a/security/BtBasics.v b/security/BtBasics.v index 2e46fe73eb..ab88bf97d2 100644 --- a/security/BtBasics.v +++ b/security/BtBasics.v @@ -186,6 +186,126 @@ forall b, b is the block of one of the counter -> 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. + + (* semantics_determinate: forall p : program, determinate (Asm.semantics p) *) + (* sd_traces: forall [L : semantics], determinate L -> single_events L *) + + 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. + + Section EXTCALL. Variant external_call_event_match_common diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index d65182c0f6..e657d7666e 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -14,9 +14,9 @@ Section BUNDLE. (* ()-no event, {}-may event, when len(tr) > 1, need to consider cuts *) (* intra/cross/virtual(default), internal/external *) Variant bundle_event : Type := - (* generate a call code + others *) + (* generate a call code + other followup events *) | Bundle_call_ci (evs: trace) (* call *) - | Bundle_call_ce (cutat: nat) (evs: trace) (* call-{ext}-ret - cutat in {1, 2, 3} *) + | Bundle_call_ce (evs: trace) (* call-{ext}-ret - cutat in {1, 2, 3} *) | Bundle_call_vi (evs: trace) (* (call) - compartment changes *) | Bundle_call_ve (evs: trace) (* (call)-ext-(ret) - call/ret cancels compartment change, so only consider when visible *) | Bundle_call_ie (evs: trace) (* (call)-ext-(ret) *) @@ -29,125 +29,6 @@ Section BUNDLE. End BUNDLE. -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. - - (* semantics_determinate: forall p : program, determinate (Asm.semantics p) *) - (* sd_traces: forall [L : semantics], determinate L -> single_events L *) - - 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. - Section INFORMATIVE. Import Smallstep. From df64b5e319043376addf6e83a09be5df322a1e96 Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 29 May 2023 17:12:23 +0200 Subject: [PATCH 058/174] defined asm step fixed - TODO replace old def --- riscV/Asm.v | 121 +++++++++++++++++++++++++++++++++++++++++++ security/BtInfoAsm.v | 36 ++++++++++--- 2 files changed, 149 insertions(+), 8 deletions(-) diff --git a/riscV/Asm.v b/riscV/Asm.v index c680aa9969..2b11908eca 100644 --- a/riscV/Asm.v +++ b/riscV/Asm.v @@ -1305,6 +1305,7 @@ Definition funsig (fd: fundef): signature := | External ef => ef_sig ef end. +(* TODO: replace with the one below *) Inductive step: state -> trace -> state -> Prop := | exec_step_internal: forall b ofs f i rs m rs' m' b' ofs' st cp, @@ -1398,6 +1399,126 @@ 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'). + +Section AUX. + + Definition block_first_order (m: mem) (b: block): Prop := + forall (ofs: Z), + match (ZMap.get ofs (Mem.mem_contents m) !! b) with + | Fragment vv _ _ => not_ptr vv + | _ => True + end. + + (* Public symbols are visible outside the compilation unit, + so when interacting via external calls, limit them to first-order. *) + Definition public_first_order (ge: Senv.t) (m: mem) := + forall id b (PUBLIC: Senv.public_symbol ge id = true) (FIND: Senv.find_symbol ge id = Some b), + block_first_order m b. + + (* We enforce Event_syscall to respect eventval_list_match on args, + which enforce pointers to be public - which should be first-order by the semantics *) + +End AUX. + +(* Two fixes: check sig when call, public first order when syscall event *) +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' ofs')), + 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.InternalCall -> + (exists fd, Genv.find_funct_ptr ge b' = Some fd /\ sig = funsig fd)), + 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), + 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 res) -> + eval_builtin_args ge rs (rs SP) m args vargs -> + external_call ef ge (comp_of f) vargs m t vres m' -> + rs' = nextinstr + (set_res res vres + (undef_regs (map preg_of (destroyed_by_builtin ef)) + (rs #X1 <- Vundef #X31 <- Vundef))) -> + (* Public global symbols should be first order *) + forall (PFO: public_first_order ge m), + 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' cp 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 cp 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 step_fixs behave like returns. So we do the same as in the [exec_step_fix_internal_return] case. *) + forall (REC_CURCOMP: Genv.find_comp_ignore_offset ge (rs PC) = callee_comp st), + (* Public global symbols should be first order *) + forall (PFO: public_first_order ge m), + step_fix (State st rs m) t (ReturnState st rs' m'). + End RELSEM. (** Execution of whole programs. *) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index e657d7666e..89e9c881d6 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -15,18 +15,38 @@ Section BUNDLE. (* intra/cross/virtual(default), internal/external *) Variant bundle_event : Type := (* generate a call code + other followup events *) - | Bundle_call_ci (evs: trace) (* call *) - | Bundle_call_ce (evs: trace) (* call-{ext}-ret - cutat in {1, 2, 3} *) - | Bundle_call_vi (evs: trace) (* (call) - compartment changes *) - | Bundle_call_ve (evs: trace) (* (call)-ext-(ret) - call/ret cancels compartment change, so only consider when visible *) - | Bundle_call_ie (evs: trace) (* (call)-ext-(ret) *) + | Bundle_call_ci (tr: trace) (sg: signature) (* call *) + | Bundle_call_ce (tr: trace) (sg: signature) (* call-{ext}-ret - cut at {1, 2, 3} *) + | Bundle_call_vi (tr: trace) (sg: signature) (* (call) - compartment changes *) + | Bundle_call_ve (tr: trace) (sg: signature) (* (call)-ext-(ret) - call/ret cancels compartment change, so only consider when visible *) + | Bundle_call_ie (tr: trace) (id: ident) (sg: signature) (* (call)-ext-(ret) *) (* generate a return code *) - | Bundle_return_ci (evs: trace) (* ret *) - | Bundle_return_vi (evs: trace) (* (ret) - compartment change *) + | Bundle_return_ci (tr: trace) (sg: signature) (* ret *) + | Bundle_return_vi (tr: trace) (sg: signature) (* (ret) - compartment change *) (* generate a builtin code *) - | Bundle_builtin (evs: trace) (* ext *) + | Bundle_builtin (tr: trace) (ef: external_function) (* ext *) . + Definition bundle_trace := list bundle_event. + + Definition unbundle (be: bundle_event): trace := + match be with + | Bundle_call_ci tr _ + | Bundle_call_ce tr _ + | Bundle_call_vi tr _ + | Bundle_call_ve tr _ + | Bundle_call_ie tr _ _ + | Bundle_return_ci tr _ + | Bundle_return_vi tr _ + | Bundle_builtin tr _ => tr + end. + + Fixpoint unbundle_trace (btr: bundle_trace) : trace := + match btr with + | be :: tl => (unbundle be) ++ (unbundle_trace tl) + | nil => nil + end. + End BUNDLE. From c6066996dfe6f31e45e269e711a9e50c8924745c Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 29 May 2023 22:47:32 +0200 Subject: [PATCH 059/174] WIP --- security/BtFromAsm.v | 2 +- security/BtInfoAsm.v | 282 ++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 265 insertions(+), 19 deletions(-) diff --git a/security/BtFromAsm.v b/security/BtFromAsm.v index dbcae55aac..30a9ffa1f2 100644 --- a/security/BtFromAsm.v +++ b/security/BtFromAsm.v @@ -5,7 +5,7 @@ Require Import AST Linking Smallstep Events Behaviors. Require Import Split. Require Import riscV.Asm. -Require Import BtInfoAsm BtBasics. +Require Import BtBasics. Section WELLFORMED. diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 89e9c881d6..24378c19d3 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -11,34 +11,48 @@ Require Import Complements. Section BUNDLE. - (* ()-no event, {}-may event, when len(tr) > 1, need to consider cuts *) - (* intra/cross/virtual(default), internal/external *) + (* (* ()-no event, {}-may event, when len(tr) > 1, need to consider cuts *) *) + (* (* intra/cross/virtual(default), internal/external *) *) + (* Variant bundle_event : Type := *) + (* (* generate a call code + other followup events *) *) + (* | Bundle_call_ci (tr: trace) (id: ident) (args: list eventval) (sg: signature) (* call *) *) + (* | Bundle_call_ce (tr: trace) (id: ident) (args: list eventval) (sg: signature) (* call-{ext}-ret - cut at {1, 2, 3} *) *) + (* | Bundle_call_vi (tr: trace) (id: ident) (args: list eventval) (sg: signature) (* (call) - compartment changes *) *) + (* | Bundle_call_ve (tr: trace) (id: ident) (args: list eventval) (sg: signature) (* (call)-ext-(ret) - also cut *) *) + (* | Bundle_call_ie (tr: trace) (id: ident) (args: list eventval) (sg: signature) (* (call)-ext-(ret) *) *) + (* (* generate a return code *) *) + (* | Bundle_return_ci (tr: trace) (sg: signature) (* ret *) *) + (* | Bundle_return_vi (tr: trace) (sg: signature) (* (ret) - compartment change *) *) + (* (* generate a builtin code *) *) + (* | Bundle_builtin (tr: trace) (ef: external_function) (* ext *) *) + (* . *) + Variant bundle_event : Type := (* generate a call code + other followup events *) - | Bundle_call_ci (tr: trace) (sg: signature) (* call *) - | Bundle_call_ce (tr: trace) (sg: signature) (* call-{ext}-ret - cut at {1, 2, 3} *) - | Bundle_call_vi (tr: trace) (sg: signature) (* (call) - compartment changes *) - | Bundle_call_ve (tr: trace) (sg: signature) (* (call)-ext-(ret) - call/ret cancels compartment change, so only consider when visible *) - | Bundle_call_ie (tr: trace) (id: ident) (sg: signature) (* (call)-ext-(ret) *) + | Bundle_call (tr: trace) (id: ident) (args: list eventval) (sg: signature) (* call-ext-ret *) (* generate a return code *) - | Bundle_return_ci (tr: trace) (sg: signature) (* ret *) - | Bundle_return_vi (tr: trace) (sg: signature) (* (ret) - compartment change *) + | Bundle_return (tr: trace) (retv: eventval) (* ret *) (* generate a builtin code *) - | Bundle_builtin (tr: trace) (ef: external_function) (* ext *) + | Bundle_builtin (tr: trace) (ef: external_function) (args: list eventval) (* ext *) . Definition bundle_trace := list bundle_event. + (* Definition unbundle (be: bundle_event): trace := *) + (* match be with *) + (* | Bundle_call_ci tr _ *) + (* | Bundle_call_ce tr _ *) + (* | Bundle_call_vi tr _ *) + (* | Bundle_call_ve tr _ *) + (* | Bundle_call_ie tr _ _ *) + (* | Bundle_return_ci tr _ *) + (* | Bundle_return_vi tr _ *) + (* | Bundle_builtin tr _ => tr *) + (* end. *) + Definition unbundle (be: bundle_event): trace := match be with - | Bundle_call_ci tr _ - | Bundle_call_ce tr _ - | Bundle_call_vi tr _ - | Bundle_call_ve tr _ - | Bundle_call_ie tr _ _ - | Bundle_return_ci tr _ - | Bundle_return_vi tr _ - | Bundle_builtin tr _ => tr + | Bundle_call tr _ _ _ | Bundle_return tr _ | Bundle_builtin tr _ _ => tr end. Fixpoint unbundle_trace (btr: bundle_trace) : trace := @@ -50,6 +64,238 @@ Section BUNDLE. End BUNDLE. +Section AUX. + + 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. + + (* Definition genv_invert_symbol_total {F V : Type} (ge : Genv.t F V) : block -> ident := *) + (* fun b => match Genv.invert_symbol ge b with | Some i => i | None => xH end. *) + + (* only virtual (default), cross cases *) + Inductive call_trace_vr {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> val -> list val -> list typ -> trace -> ident -> list eventval -> Prop := + | call_trace_vr_virtual : forall (cp cp' : compartment) (vf : val) (vargs : list val) (vl : list eventval) (ty : list typ) (b : block) (ofs : ptrofs) (i : ident), + Genv.type_of_call ge cp cp' = Genv.DefaultCompartmentCall -> + vf = Vptr b ofs -> Genv.invert_symbol ge b = Some i -> (vl = typ_to_eventvals ty) -> call_trace_vr ge cp cp' vf vargs ty E0 i vl + | call_trace_vr_cross : forall (cp cp' : compartment) (vf : val) (vargs : list val) (vl : list eventval) (ty : list typ) (b : block) (ofs : ptrofs) (i : ident), + Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> + vf = Vptr b ofs -> Genv.invert_symbol ge b = Some i -> eventval_list_match ge vl ty vargs -> call_trace_vr ge cp cp' vf vargs ty (Event_call cp cp' i vl :: nil) i vl. + + Inductive return_trace_vr {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> val -> rettype -> trace -> eventval -> Prop := + | return_trace_vr_virtual : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype), + Genv.type_of_call ge cp cp' = Genv.DefaultCompartmentCall -> (res = typ_to_eventval (proj_rettype ty)) -> return_trace_vr ge cp cp' v ty E0 res + | return_trace_vr_cross : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype), + Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> eventval_match ge res (proj_rettype ty) v -> return_trace_vr ge cp cp' v ty (Event_return cp cp' res :: nil) res. + + (* intra external call case *) + +End AUX. + + +Section WELLFORMED. + + (* Variant sf_cont_type : Type := | sf_cont: block -> signature -> sf_cont_type. *) + Variant sf_cont_type : Type := | sf_cont: block -> sf_cont_type. + Definition sf_conts := list sf_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 virtual_reality (ct: Genv.call_type): Prop := + match ct with + | Genv.InternalCall => False + | Genv.CrossCompartmentCall => False + | Genv.DefaultCompartmentCall => True + end. + + Variant info_asm_sem_wf (ge: Asm.genv) : block -> mem -> sf_conts -> bundle_event -> Prop := + | info_asm_sem_wf_call_cross_internal + cur m1 sf tr sg + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + cp' fid evargs + (EV: ev = Event_call cp cp' fid evargs) + sg + b + (FINDB: Genv.find_symbol ge fid = Some b) + fd + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (CP': cp' = comp_of fd) + (VR: virtual_reality (Genv.type_of_call ge cp cp') vr) + (* (CROSS: Genv.type_of_call ge cp cp' <> Genv.InternalCall) *) + args + (NPTR: crossing_comp ge cp cp' -> Forall not_ptr args) + (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) + (ESM: crossing_comp ge cp cp' -> eventval_list_match ge evargs (sig_args sg) args) + (SIG: sg = Asm.funsig fd) + (NEXT: info_asm_sem_wf ge b m1 ((sf_cont cur) :: sf) tl) + : + info_asm_sem_wf ge cur m1 sf (Bundle_call_ci tr sg) + | Bundle_call_ci (tr: trace) (sg: signature) (* call *) + | Bundle_call_ce (tr: trace) (sg: signature) (* call-{ext}-ret - cut at {1, 2, 3} *) + | Bundle_call_vi (tr: trace) (sg: signature) (* (call) - compartment changes *) + | Bundle_call_ve (tr: trace) (sg: signature) (* (call)-ext-(ret) - also cut *) + | Bundle_call_ie (tr: trace) (id: ident) (sg: signature) (* (call)-ext-(ret) *) + | Bundle_return_ci (tr: trace) (sg: signature) (* ret *) + | Bundle_return_vi (tr: trace) (sg: signature) (* (ret) - compartment change *) + | Bundle_builtin (tr: trace) (ef: external_function) (* ext *) + | info_asm_sem_wf_cross_return_internal + cur m1 ev ik vr tl + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + cp_c evres + (EV: ev = Event_return cp_c cp evres) + sg + (IK: ik = info_return sg vr) + cur_f + (INTERNAL: Genv.find_funct_ptr ge cur = Some (AST.Internal cur_f)) + (* Follows from cross call - stack has the sig *) + (SIG: sg = Asm.fn_sig cur_f) + (VR: virtual_reality (Genv.type_of_call ge cp_c cp) vr) + res + (EVM: crossing_comp ge cp_c cp -> eventval_match ge evres (proj_rettype (sig_res sg)) res) + (NPTR: crossing_comp ge cp_c cp -> not_ptr res) + b_c sf_tl + (CPC: cp_c = Genv.find_comp ge (Vptr b_c Ptrofs.zero)) + (* internal return: memory changes in Clight-side, so need inj-relation *) + (NEXT: info_asm_sem_wf ge b_c m1 sf_tl tl) + : + info_asm_sem_wf ge cur m1 ((sf_cont b_c) :: sf_tl) ((ev, ik) :: tl) + | info_asm_sem_wf_intra_call_external + cur m1 sf ev ik tl + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + ef res m2 + (EXTEV: external_call_event_match_common ef ev ge cp m1 res m2) + fb + (IK: ik = info_external fb (ef_sig ef)) + fid + (INV: Genv.invert_symbol ge fb = Some fid) + (ISEXT: Genv.find_funct_ptr ge fb = Some (AST.External ef)) + (ALLOWED: Genv.allowed_call ge cp (Vptr fb Ptrofs.zero)) + (INTRA: Genv.type_of_call ge cp (Genv.find_comp ge (Vptr fb Ptrofs.zero)) = Genv.InternalCall) + (NEXT: info_asm_sem_wf ge cur m2 sf tl) + : + info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) + | info_asm_sem_wf_builtin + cur m1 sf ev ik tl + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + ef res m2 + (EXT: external_call_event_match_common ef ev ge cp m1 res m2) + (IK: ik = info_builtin ef) + (NEXT: info_asm_sem_wf ge cur m2 sf tl) + : + info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) + | info_asm_sem_wf_cross_call_external1 + (* early cut at call event *) + cur m1 sf ev vr ik + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + cp' fid evargs + (EV: ev = Event_call cp cp' fid evargs) + sg + (IK: ik = info_call is_cross_ext sg vr) + b + (FINDB: Genv.find_symbol ge fid = Some b) + fd + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (CP': cp' = comp_of fd) + (VR: virtual_reality (Genv.type_of_call ge cp cp') vr) + args + (NPTR: crossing_comp ge cp cp' -> Forall not_ptr args) + (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) + (ESM: crossing_comp ge cp cp' -> eventval_list_match ge evargs (sig_args sg) args) + ef + (EXTERNAL: fd = AST.External ef) + (SIG: sg = ef_sig ef) + : + info_asm_sem_wf ge cur m1 sf ((ev, ik) :: nil) + | info_asm_sem_wf_cross_call_external2 + (* early cut at call-ext_call event *) + cur m1 sf ev1 vr1 ik1 + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + cp' fid evargs + (EV: ev1 = Event_call cp cp' fid evargs) + sg + (IK: ik1 = info_call is_cross_ext sg vr1) + b + (FINDB: Genv.find_symbol ge fid = Some b) + fd + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (CP': cp' = comp_of fd) + (VR: virtual_reality (Genv.type_of_call ge cp cp') vr1) + args + (NPTR: crossing_comp ge cp cp' -> Forall not_ptr args) + (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) + (ESM: crossing_comp ge cp cp' -> eventval_list_match ge evargs (sig_args sg) args) + ef + (EXTERNAL: fd = AST.External ef) + (SIG: sg = ef_sig ef) + (* external call part *) + tr vres m2 + (EXTCALL: external_call ef ge cp args m1 tr vres m2) + itr + (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) + : + info_asm_sem_wf ge cur m1 sf ((ev1, ik1) :: itr) + | info_asm_sem_wf_cross_call_external3 + (* full call-ext_call-return event *) + cur m1 sf ev1 vr1 ik1 + cp + (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) + cp' fid evargs + (EV: ev1 = Event_call cp cp' fid evargs) + sg + (IK: ik1 = info_call is_cross_ext sg vr1) + b + (FINDB: Genv.find_symbol ge fid = Some b) + fd + (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) + (CP': cp' = comp_of fd) + (VR1: virtual_reality (Genv.type_of_call ge cp cp') vr1) + args + (NPTR: crossing_comp ge cp cp' -> Forall not_ptr args) + (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) + (ESM: crossing_comp ge cp cp' -> eventval_list_match ge evargs (sig_args sg) args) + ef + (EXTERNAL: fd = AST.External ef) + (SIG: sg = ef_sig ef) + (* external call part *) + tr vres m2 + (EXTCALL: external_call ef ge cp args m1 tr vres m2) + itr + (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) + (* return part *) + ev3 vr3 ik3 tl + evres + (EV: ev3 = Event_return cp cp' evres) + sg + (IK: ik3 = info_return sg vr3) + (VR2: virtual_reality (Genv.type_of_call ge cp cp') vr3) + (EVM: crossing_comp ge cp cp' -> eventval_match ge evres (proj_rettype (sig_res sg)) vres) + (NPTR: crossing_comp ge cp cp' -> not_ptr vres) + (NEXT: info_asm_sem_wf ge cur m2 sf tl) + : + info_asm_sem_wf ge cur m1 sf ((ev1, ik1) :: (itr ++ ((ev3, ik3) :: tl))) + . + + (* TODO *) + (* we need a more precise invariant for the proof; counters, mem_inj, env, cont, state *) + +End WELLFORMED. + + Section INFORMATIVE. Import Smallstep. From 7b91b8d7fc50ec6a14b9f9824ce61454b76d443c Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 31 May 2023 18:36:42 +0200 Subject: [PATCH 060/174] WIP --- common/Events.v | 70 +++++++ riscV/Asm.v | 33 +--- security/BtFromAsm.v | 1 + security/BtInfoAsm.v | 446 +++++++++++++++++++++++++------------------ 4 files changed, 333 insertions(+), 217 deletions(-) diff --git a/common/Events.v b/common/Events.v index 6b991d74cf..b558e512b0 100644 --- a/common/Events.v +++ b/common/Events.v @@ -2120,3 +2120,73 @@ Section INFORM_TRACES_PRESERVED. Qed. End INFORM_TRACES_PRESERVED. + + +Section LEAK. + + Definition block_first_order (m: mem) (b: block): Prop := + forall (ofs: Z), + match (ZMap.get ofs (Mem.mem_contents m) !! b) with + | Fragment vv _ _ => not_ptr vv + | _ => True + end. + + (* Public symbols are visible outside the compilation unit, + so when interacting via external calls, limit them to first-order. *) + Definition public_first_order (ge: Senv.t) (m: mem) := + forall id b (PUBLIC: Senv.public_symbol ge id = true) (FIND: Senv.find_symbol ge id = Some b), + block_first_order m b. + + Definition val_first_order (m: mem) (v: val): Prop := + match v with + | Vptr b _ => block_first_order m b + | Vundef => False + | _ => True + end. + + Definition vals_first_order (m: mem) (vs: list val): Prop := + Forall (val_first_order m) vs. + + Definition block_public (ge: Senv.t) (b: block): Prop := + exists id, Senv.invert_symbol ge b = Some id /\ Senv.public_symbol ge id = true. + + Definition val_public (ge: Senv.t) (v: val): Prop := + match v with + | Vptr b _ => block_public ge b + | Vundef => False + | _ => True + end. + + Definition vals_public (ge: Senv.t) (vs: list val): Prop := + Forall (val_public ge) vs. + + Definition limit_leaks (ge: Senv.t) (m: mem) (args: list val): Prop := + public_first_order ge m /\ vals_public ge args. + + Lemma limit_leaks_ensures_args_first_order + ge m args + (LL: limit_leaks ge m args) + : + vals_first_order m args. + Proof. + revert LL. induction args; intros; simpl. econstructor. + inv LL. inv H0. econstructor; eauto. + - destruct a; simpl in *; auto. destruct H3 as (id & INV & PUB). + apply Senv.invert_find_symbol in INV. specialize (H id b PUB INV). auto. + - apply IHargs. red. auto. + Qed. + + Definition limit_leaks_if_unknown + (ef: external_function) (ge: Senv.t) (m: mem) (args: list val) : Prop := + match ef with + | EF_external name cp sg => limit_leaks ge m args + | EF_builtin name sg | EF_runtime name sg => + match lookup_builtin_function name sg with + | None => limit_leaks ge m args + | _ => True + end + | EF_inline_asm txt sg clb => limit_leaks ge m args + | _ => True + end. + +End LEAK. diff --git a/riscV/Asm.v b/riscV/Asm.v index 2b11908eca..54353a295e 100644 --- a/riscV/Asm.v +++ b/riscV/Asm.v @@ -1305,7 +1305,7 @@ Definition funsig (fd: fundef): signature := | External ef => ef_sig ef end. -(* TODO: replace with the one below *) +(* 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, @@ -1399,28 +1399,7 @@ 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'). - -Section AUX. - - Definition block_first_order (m: mem) (b: block): Prop := - forall (ofs: Z), - match (ZMap.get ofs (Mem.mem_contents m) !! b) with - | Fragment vv _ _ => not_ptr vv - | _ => True - end. - - (* Public symbols are visible outside the compilation unit, - so when interacting via external calls, limit them to first-order. *) - Definition public_first_order (ge: Senv.t) (m: mem) := - forall id b (PUBLIC: Senv.public_symbol ge id = true) (FIND: Senv.find_symbol ge id = Some b), - block_first_order m b. - - (* We enforce Event_syscall to respect eventval_list_match on args, - which enforce pointers to be public - which should be first-order by the semantics *) - -End AUX. - -(* Two fixes: check sig when call, public first order when syscall event *) +(* Two fixes: check sig when call CALLSIG, public & first order args when undefined external call LL *) Inductive step_fix: state -> trace -> state -> Prop := | exec_step_fix_internal: forall b ofs f i rs m rs' m' b' ofs' st cp, @@ -1502,8 +1481,8 @@ Inductive step_fix: state -> trace -> state -> Prop := (set_res res vres (undef_regs (map preg_of (destroyed_by_builtin ef)) (rs #X1 <- Vundef #X31 <- Vundef))) -> - (* Public global symbols should be first order *) - forall (PFO: public_first_order ge m), + (* Limit leaks when calling unknown function *) + forall (LL: limit_leaks_if_unknown 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' cp st, @@ -1515,8 +1494,8 @@ Inductive step_fix: state -> trace -> state -> Prop := rs' = (set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs))#PC <- (rs RA) -> (* These step_fixs behave like returns. So we do the same as in the [exec_step_fix_internal_return] case. *) forall (REC_CURCOMP: Genv.find_comp_ignore_offset ge (rs PC) = callee_comp st), - (* Public global symbols should be first order *) - forall (PFO: public_first_order ge m), + (* Limit leaks when calling unknown function *) + forall (LL: limit_leaks_if_unknown ef ge m args), step_fix (State st rs m) t (ReturnState st rs' m'). End RELSEM. diff --git a/security/BtFromAsm.v b/security/BtFromAsm.v index 30a9ffa1f2..065aa3d73c 100644 --- a/security/BtFromAsm.v +++ b/security/BtFromAsm.v @@ -205,6 +205,7 @@ Section MATCH. Variant match_stack_type : (sf_cont_type) -> (stackframe) -> Prop := | match_stack_type_intro b cp sg v ofs + (* needs to talk about sig in stack *) : match_stack_type (sf_cont b) (Stackframe b cp sg v ofs). diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 24378c19d3..988f9ced39 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -7,6 +7,7 @@ Require Import Split. Require Import riscV.Machregs. Require Import riscV.Asm. Require Import Complements. +Require Import BtBasics. Section BUNDLE. @@ -81,14 +82,14 @@ Section AUX. (* Definition genv_invert_symbol_total {F V : Type} (ge : Genv.t F V) : block -> ident := *) (* fun b => match Genv.invert_symbol ge b with | Some i => i | None => xH end. *) - (* only virtual (default), cross cases *) - Inductive call_trace_vr {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> val -> list val -> list typ -> trace -> ident -> list eventval -> Prop := - | call_trace_vr_virtual : forall (cp cp' : compartment) (vf : val) (vargs : list val) (vl : list eventval) (ty : list typ) (b : block) (ofs : ptrofs) (i : ident), + (* only virtual (default) or real (cross) cases *) + Inductive call_trace_vr {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> block -> list val -> list typ -> trace -> ident -> list eventval -> Prop := + | call_trace_vr_virtual : forall (cp cp' : compartment) (b : block) (vargs : list val) (vl : list eventval) (ty : list typ) (i : ident), Genv.type_of_call ge cp cp' = Genv.DefaultCompartmentCall -> - vf = Vptr b ofs -> Genv.invert_symbol ge b = Some i -> (vl = typ_to_eventvals ty) -> call_trace_vr ge cp cp' vf vargs ty E0 i vl - | call_trace_vr_cross : forall (cp cp' : compartment) (vf : val) (vargs : list val) (vl : list eventval) (ty : list typ) (b : block) (ofs : ptrofs) (i : ident), + Genv.invert_symbol ge b = Some i -> (vl = typ_to_eventvals ty) -> call_trace_vr ge cp cp' b vargs ty E0 i vl + | call_trace_vr_cross : forall (cp cp' : compartment) (b : block) (vargs : list val) (vl : list eventval) (ty : list typ) (i : ident), Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> - vf = Vptr b ofs -> Genv.invert_symbol ge b = Some i -> eventval_list_match ge vl ty vargs -> call_trace_vr ge cp cp' vf vargs ty (Event_call cp cp' i vl :: nil) i vl. + Genv.invert_symbol ge b = Some i -> eventval_list_match ge vl ty vargs -> call_trace_vr ge cp cp' b vargs ty (Event_call cp cp' i vl :: nil) i vl. Inductive return_trace_vr {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> val -> rettype -> trace -> eventval -> Prop := | return_trace_vr_virtual : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype), @@ -96,204 +97,269 @@ Section AUX. | return_trace_vr_cross : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype), Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> eventval_match ge res (proj_rettype ty) v -> return_trace_vr ge cp cp' v ty (Event_return cp cp' res :: nil) res. - (* intra external call case *) + (* 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. End AUX. -Section WELLFORMED. +Section IR. - (* Variant sf_cont_type : Type := | sf_cont: block -> signature -> sf_cont_type. *) - Variant sf_cont_type : Type := | sf_cont: block -> sf_cont_type. - Definition sf_conts := list sf_cont_type. + Variant ir_cont_type : Type := | ir_cont: block -> signature -> 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 virtual_reality (ct: Genv.call_type): Prop := - match ct with - | Genv.InternalCall => False - | Genv.CrossCompartmentCall => False - | Genv.DefaultCompartmentCall => True - end. + Definition ir_state := option (block * mem * ir_conts)%type. + + Variant ir_step (ge: Asm.genv) : ir_state -> bundle_event -> ir_state -> Prop := + | ir_step_vr_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_vr ge cp cp' b vargs (sig_args sg) tr id evargs) + : + ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg) (Some (b, m1, (ir_cont cur sg) :: ik)) + | ir_step_vr_return_internal + cur m1 next 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 --- TODO : false? fix? *) + (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_vr ge cp_next cp_cur vretv (sig_res sg) tr evretv) + : + ir_step ge (Some (cur, m1, ((ir_cont next sg) :: ik_tl))) (Bundle_return tr evretv) (Some (next, m1, 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) + vargs vretv + (EC: external_call ef ge cp_cur vargs m1 tr vretv m2) + (LL: limit_leaks_if_unknown ef ge m1 vargs) + (ARGS: evargs = vals_to_eventvals ge vargs) + : + ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg) (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)) + vargs vretv + (EC: external_call ef ge cp_cur vargs m1 tr vretv m2) + (LL: limit_leaks_if_unknown ef ge m1 vargs) + (ARGS: evargs = vals_to_eventvals ge vargs) + : + ir_step ge (Some (cur, m1, ik)) (Bundle_builtin tr ef evargs) (Some (cur, m2, ik)) + | ir_step_vr_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_vr ge cp cp' b vargs (sig_args sg) tr id evargs) + : + ir_step ge (Some (cur, m1, ik)) (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) + (TR: call_trace_vr ge cp cp' b vargs (sig_args sg) tr1 id evargs) + (* external function part *) + tr2 m2 vretv + (EC: external_call ef ge cp vargs m1 tr2 vretv m2) + (LL: limit_leaks_if_unknown ef ge m1 vargs) + (ARGS: evargs = vals_to_eventvals ge vargs) + : + ir_step ge (Some (cur, m1, ik)) (Bundle_call (tr1 ++ tr2) id evargs sg) 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_vr ge cp cp' b vargs (sig_args sg) tr1 id evargs) + (* external function part *) + tr2 m2 vretv + (TR2: external_call ef ge cp vargs m1 tr2 vretv m2) + (LL: limit_leaks_if_unknown ef ge m1 vargs) + (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_vr ge cp cp' vretv (sig_res sg) tr3 evretv) + : + ir_step ge (Some (cur, m1, ik)) (Bundle_call (tr1 ++ tr2 ++ tr3) id evargs sg) (Some (cur, m2, ik)). + + (* we need a more precise invariant for the proof for Clight; counters, mem_inj, env, cont, state *) + +End IR. - Variant info_asm_sem_wf (ge: Asm.genv) : block -> mem -> sf_conts -> bundle_event -> Prop := - | info_asm_sem_wf_call_cross_internal - cur m1 sf tr sg - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - cp' fid evargs - (EV: ev = Event_call cp cp' fid evargs) - sg - b - (FINDB: Genv.find_symbol ge fid = Some b) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (CP': cp' = comp_of fd) - (VR: virtual_reality (Genv.type_of_call ge cp cp') vr) - (* (CROSS: Genv.type_of_call ge cp cp' <> Genv.InternalCall) *) - args - (NPTR: crossing_comp ge cp cp' -> Forall not_ptr args) - (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) - (ESM: crossing_comp ge cp cp' -> eventval_list_match ge evargs (sig_args sg) args) - (SIG: sg = Asm.funsig fd) - (NEXT: info_asm_sem_wf ge b m1 ((sf_cont cur) :: sf) tl) - : - info_asm_sem_wf ge cur m1 sf (Bundle_call_ci tr sg) - | Bundle_call_ci (tr: trace) (sg: signature) (* call *) - | Bundle_call_ce (tr: trace) (sg: signature) (* call-{ext}-ret - cut at {1, 2, 3} *) - | Bundle_call_vi (tr: trace) (sg: signature) (* (call) - compartment changes *) - | Bundle_call_ve (tr: trace) (sg: signature) (* (call)-ext-(ret) - also cut *) - | Bundle_call_ie (tr: trace) (id: ident) (sg: signature) (* (call)-ext-(ret) *) - | Bundle_return_ci (tr: trace) (sg: signature) (* ret *) - | Bundle_return_vi (tr: trace) (sg: signature) (* (ret) - compartment change *) - | Bundle_builtin (tr: trace) (ef: external_function) (* ext *) - | info_asm_sem_wf_cross_return_internal - cur m1 ev ik vr tl - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - cp_c evres - (EV: ev = Event_return cp_c cp evres) - sg - (IK: ik = info_return sg vr) - cur_f - (INTERNAL: Genv.find_funct_ptr ge cur = Some (AST.Internal cur_f)) - (* Follows from cross call - stack has the sig *) - (SIG: sg = Asm.fn_sig cur_f) - (VR: virtual_reality (Genv.type_of_call ge cp_c cp) vr) - res - (EVM: crossing_comp ge cp_c cp -> eventval_match ge evres (proj_rettype (sig_res sg)) res) - (NPTR: crossing_comp ge cp_c cp -> not_ptr res) - b_c sf_tl - (CPC: cp_c = Genv.find_comp ge (Vptr b_c Ptrofs.zero)) - (* internal return: memory changes in Clight-side, so need inj-relation *) - (NEXT: info_asm_sem_wf ge b_c m1 sf_tl tl) - : - info_asm_sem_wf ge cur m1 ((sf_cont b_c) :: sf_tl) ((ev, ik) :: tl) - | info_asm_sem_wf_intra_call_external - cur m1 sf ev ik tl - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - ef res m2 - (EXTEV: external_call_event_match_common ef ev ge cp m1 res m2) - fb - (IK: ik = info_external fb (ef_sig ef)) - fid - (INV: Genv.invert_symbol ge fb = Some fid) - (ISEXT: Genv.find_funct_ptr ge fb = Some (AST.External ef)) - (ALLOWED: Genv.allowed_call ge cp (Vptr fb Ptrofs.zero)) - (INTRA: Genv.type_of_call ge cp (Genv.find_comp ge (Vptr fb Ptrofs.zero)) = Genv.InternalCall) - (NEXT: info_asm_sem_wf ge cur m2 sf tl) - : - info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) - | info_asm_sem_wf_builtin - cur m1 sf ev ik tl - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - ef res m2 - (EXT: external_call_event_match_common ef ev ge cp m1 res m2) - (IK: ik = info_builtin ef) - (NEXT: info_asm_sem_wf ge cur m2 sf tl) - : - info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) - | info_asm_sem_wf_cross_call_external1 - (* early cut at call event *) - cur m1 sf ev vr ik - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - cp' fid evargs - (EV: ev = Event_call cp cp' fid evargs) - sg - (IK: ik = info_call is_cross_ext sg vr) - b - (FINDB: Genv.find_symbol ge fid = Some b) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (CP': cp' = comp_of fd) - (VR: virtual_reality (Genv.type_of_call ge cp cp') vr) - args - (NPTR: crossing_comp ge cp cp' -> Forall not_ptr args) - (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) - (ESM: crossing_comp ge cp cp' -> eventval_list_match ge evargs (sig_args sg) args) - ef - (EXTERNAL: fd = AST.External ef) - (SIG: sg = ef_sig ef) - : - info_asm_sem_wf ge cur m1 sf ((ev, ik) :: nil) - | info_asm_sem_wf_cross_call_external2 - (* early cut at call-ext_call event *) - cur m1 sf ev1 vr1 ik1 - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - cp' fid evargs - (EV: ev1 = Event_call cp cp' fid evargs) - sg - (IK: ik1 = info_call is_cross_ext sg vr1) - b - (FINDB: Genv.find_symbol ge fid = Some b) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (CP': cp' = comp_of fd) - (VR: virtual_reality (Genv.type_of_call ge cp cp') vr1) - args - (NPTR: crossing_comp ge cp cp' -> Forall not_ptr args) - (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) - (ESM: crossing_comp ge cp cp' -> eventval_list_match ge evargs (sig_args sg) args) - ef - (EXTERNAL: fd = AST.External ef) - (SIG: sg = ef_sig ef) - (* external call part *) - tr vres m2 - (EXTCALL: external_call ef ge cp args m1 tr vres m2) - itr - (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) + +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) : - info_asm_sem_wf ge cur m1 sf ((ev1, ik1) :: itr) - | info_asm_sem_wf_cross_call_external3 - (* full call-ext_call-return event *) - cur m1 sf ev1 vr1 ik1 - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - cp' fid evargs - (EV: ev1 = Event_call cp cp' fid evargs) - sg - (IK: ik1 = info_call is_cross_ext sg vr1) - b - (FINDB: Genv.find_symbol ge fid = Some b) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (CP': cp' = comp_of fd) - (VR1: virtual_reality (Genv.type_of_call ge cp cp') vr1) - args - (NPTR: crossing_comp ge cp cp' -> Forall not_ptr args) - (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) - (ESM: crossing_comp ge cp cp' -> eventval_list_match ge evargs (sig_args sg) args) - ef - (EXTERNAL: fd = AST.External ef) - (SIG: sg = ef_sig ef) - (* external call part *) - tr vres m2 - (EXTCALL: external_call ef ge cp args m1 tr vres m2) - itr - (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) - (* return part *) - ev3 vr3 ik3 tl - evres - (EV: ev3 = Event_return cp cp' evres) - sg - (IK: ik3 = info_return sg vr3) - (VR2: virtual_reality (Genv.type_of_call ge cp cp') vr3) - (EVM: crossing_comp ge cp cp' -> eventval_match ge evres (proj_rettype (sig_res sg)) vres) - (NPTR: crossing_comp ge cp cp' -> not_ptr vres) - (NEXT: info_asm_sem_wf ge cur m2 sf tl) + 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) : - info_asm_sem_wf ge cur m1 sf ((ev1, ik1) :: (itr ++ ((ev3, ik3) :: tl))) - . + (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 ASMTOIR. + + (* fix sig? *) + Definition wf_ir (ge: Asm.genv) (ist: ir_state) := + match ist with + | Some (cur, _, ik) => + match Genv.find_funct_ptr ge cur with + | Some (Internal f) => + | _ => False + end. + + 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 match_cur_stack (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). + + Variant match_stackframe : ir_cont_type -> stackframe -> Prop := + | match_stackframe_intro + b cp sg v ofs + (* needs to talk about sig in stack *) + : + match_stack_type (sf_cont b) (Stackframe b cp sg v ofs). + + + Variant match_stack_type : (sf_cont_type) -> (stackframe) -> Prop := + | match_stack_type_intro + b cp sg v ofs + (* needs to talk about sig in stack *) + : + match_stack_type (sf_cont b) (Stackframe b cp sg v ofs). + + Definition match_stack (sf: sf_conts) (st: stack) := Forall2 match_stack_type sf st. + + Definition match_cp (ge: Asm.genv) (cur: block) (cp: compartment) : Prop := + Genv.find_comp ge (Vptr cur Ptrofs.zero) = cp. + + Definition meminj_ge {F V} (ge: Genv.t F V): meminj := + fun b => match Genv.invert_symbol ge b with + | Some id => match Genv.find_symbol ge id with + | Some b' => Some (b', 0) + | None => None + end + | None => None + end. + + Definition match_mem (ge: Asm.genv) (m_ir m_asm: mem): Prop := Mem.inject (meminj_ge ge) m_asm m_ir. + - (* TODO *) - (* we need a more precise invariant for the proof; counters, mem_inj, env, cont, state *) +End ASMTOIR. -End WELLFORMED. Section INFORMATIVE. From 651042577ccbab086b3d6c36210e5c97c2664b06 Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 2 Jun 2023 12:14:24 +0200 Subject: [PATCH 061/174] WIP --- common/Events.v | 84 +++++++-------- security/BtInfoAsm.v | 243 +++++++++++++++++++++++++++++++++++-------- 2 files changed, 240 insertions(+), 87 deletions(-) diff --git a/common/Events.v b/common/Events.v index b558e512b0..c3ef9e7f2c 100644 --- a/common/Events.v +++ b/common/Events.v @@ -2124,69 +2124,63 @@ End INFORM_TRACES_PRESERVED. Section LEAK. - Definition block_first_order (m: mem) (b: block): Prop := - forall (ofs: Z), - match (ZMap.get ofs (Mem.mem_contents m) !! b) with - | Fragment vv _ _ => not_ptr vv - | _ => True - end. + (* 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. *) + 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 (PUBLIC: Senv.public_symbol ge id = true) (FIND: Senv.find_symbol ge id = Some b), - block_first_order m b. - - Definition val_first_order (m: mem) (v: val): Prop := - match v with - | Vptr b _ => block_first_order m b - | Vundef => False - | _ => True - end. - - Definition vals_first_order (m: mem) (vs: list val): Prop := - Forall (val_first_order m) vs. + 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. - Definition val_public (ge: Senv.t) (v: val): Prop := - match v with - | Vptr b _ => block_public ge b - | Vundef => False - | _ => True - end. + 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) (vs: list val): Prop := - Forall (val_public ge) vs. + Definition vals_public (ge: Senv.t) (ts: list typ) (vs: list val): Prop := + Forall2 (val_public ge) ts vs. - Definition limit_leaks (ge: Senv.t) (m: mem) (args: list val): Prop := - public_first_order ge m /\ vals_public ge args. - - Lemma limit_leaks_ensures_args_first_order - ge m args - (LL: limit_leaks ge m args) - : - vals_first_order m args. - Proof. - revert LL. induction args; intros; simpl. econstructor. - inv LL. inv H0. econstructor; eauto. - - destruct a; simpl in *; auto. destruct H3 as (id & INV & PUB). - apply Senv.invert_find_symbol in INV. specialize (H id b PUB INV). auto. - - apply IHargs. red. auto. - Qed. + Definition limit_leaks (ge: Senv.t) (m: mem) (tys: list typ) (args: list val): Prop := + public_first_order ge m /\ vals_public ge tys args. Definition limit_leaks_if_unknown (ef: external_function) (ge: Senv.t) (m: mem) (args: list val) : Prop := match ef with - | EF_external name cp sg => limit_leaks ge m args + | EF_external name cp sg => limit_leaks ge m (sig_args sg) args | EF_builtin name sg | EF_runtime name sg => match lookup_builtin_function name sg with - | None => limit_leaks ge m args + | None => limit_leaks ge m (sig_args sg) args | _ => True end - | EF_inline_asm txt sg clb => limit_leaks ge m args + | EF_inline_asm txt sg clb => limit_leaks ge m (sig_args sg) args | _ => True end. + Definition limit_leaks_and_unknown + (ef: external_function) (ge: Senv.t) (m: mem) (args: list val) : Prop := + match ef with + | EF_external name cp sg => limit_leaks ge m (sig_args sg) args + | EF_builtin name sg | EF_runtime name sg => + match lookup_builtin_function name sg with + | None => limit_leaks ge m (sig_args sg) args + | _ => False + end + | EF_inline_asm txt sg clb => limit_leaks ge m (sig_args sg) args + | _ => False + end. + End LEAK. diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 988f9ced39..6807e70297 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -119,9 +119,141 @@ Section AUX. End AUX. +Section MEMDATA. + + Record mem_weak_inj (f : meminj) (m1 m2 : mem) : Prop := + mk_mem_weak_inj + { mwi_perm : forall (b1 b2 : block) (delta ofs : Z) (k : perm_kind) (p : permission), + f b1 = Some (b2, delta) -> Mem.perm m1 b1 ofs k p -> Mem.perm m2 b2 (ofs + delta) k p; + mwi_own : forall (b1 b2 : block) (delta : Z) (cp : option compartment), + f b1 = Some (b2, delta) -> Mem.can_access_block m1 b1 cp -> Mem.can_access_block m2 b2 cp; + mwi_align : forall (b1 b2 : block) (delta : Z) (chunk : memory_chunk) (ofs : Z) (p : permission), + f b1 = Some (b2, delta) -> Mem.range_perm m1 b1 ofs (ofs + size_chunk chunk) Max p -> (align_chunk chunk | delta)%Z; + mwi_memval : forall (b1 : block) (ofs : Z) (b2 : block) (delta : Z), + f b1 = Some (b2, delta) -> ((Mem.mem_access m1) !! b1 ofs Cur = Some Readable) -> + memval_inject f (ZMap.get ofs (Mem.mem_contents m1) !! b1) (ZMap.get (ofs + delta)%Z (Mem.mem_contents m2) !! b2) }. + + Record weak_inject (f : meminj) (m1 m2 : mem) : Prop := + mk_weak_inject + { mwi_inj : mem_weak_inj f m1 m2; + mwi_freeblocks : forall b : block, ~ Mem.valid_block m1 b -> f b = None; + mwi_mappedblocks : forall (b b' : block) (delta : Z), f b = Some (b', delta) -> Mem.valid_block m2 b'; + mwi_no_overlap : Mem.meminj_no_overlap f m1; + mwi_representable : forall (b b' : block) (delta : Z) (ofs : ptrofs), + f b = Some (b', delta) -> + Mem.perm m1 b (Ptrofs.unsigned ofs) Max Nonempty \/ Mem.perm m1 b (Ptrofs.unsigned ofs - 1) Max Nonempty -> (delta >= 0)%Z /\ (0 <= Ptrofs.unsigned ofs + delta <= Ptrofs.max_unsigned)%Z; + mwi_perm_inv : forall (b1 : block) (ofs : Z) (b2 : block) (delta : Z) (k : perm_kind) (p : permission), + f b1 = Some (b2, delta) -> Mem.perm m2 b2 (ofs + delta) k p -> Mem.perm m1 b1 ofs k p \/ ~ Mem.perm m1 b1 ofs Max Nonempty }. + + 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. + + Lemma memval_inject_get_store_get + m m_ephemeral + b ofs + v + (GET: ZMap.get ofs (Mem.mem_contents m) !! b = v) + (STORE: Mem.store + +Mem.getN_setN_same: forall (vl : list memval) (p : Z) (c : ZMap.t memval), Mem.getN (Datatypes.length vl) p (Mem.setN vl p c) = vl + + memval_inject f (ZMap.get ofs (Mem.mem_contents m1) !! b1) (ZMap.get (ofs + delta)%Z (Mem.mem_contents m2) !! b2) }. + +Genv.alloc_global = +fun (F V : Type) (CF : has_comp F) (ge : Genv.t F V) (m : mem) (idg : ident * globdef F V) => +let (_, g) := idg in +match g with +| Gfun f => let (m1, b) := Mem.alloc m (comp_of f) 0 1 in Mem.drop_perm m1 b 0 1 Nonempty (comp_of f) +| Gvar v => + let init := gvar_init v in + let comp := gvar_comp v in + let sz := init_data_list_size init in + let (m1, b) := Mem.alloc m comp 0 sz in + match store_zeros m1 b 0 sz comp with + | Some m2 => match Genv.store_init_data_list ge m2 b 0 init comp with + | Some m3 => Mem.drop_perm m3 b 0 sz (Genv.perm_globvar v) comp + | None => None + end + | None => None + end +end + : forall F V : Type, has_comp F -> Genv.t F V -> mem -> ident * globdef F V -> option mem + +Definition access_mode (ty: type) : mode := + match ty with + | Tint I8 Signed _ => By_value Mint8signed + | Tint I8 Unsigned _ => By_value Mint8unsigned + | Tint I16 Signed _ => By_value Mint16signed + | Tint I16 Unsigned _ => By_value Mint16unsigned + | Tint I32 _ _ => By_value Mint32 + | Tint IBool _ _ => By_value Mint8unsigned + | Tlong _ _ => By_value Mint64 + | Tfloat F32 _ => By_value Mfloat32 + | Tfloat F64 _ => By_value Mfloat64 + | Tvoid => By_nothing + | Tpointer _ _ => By_value Mptr + | Tarray _ _ _ => By_reference + | Tfunction _ _ _ => By_reference + | Tstruct _ _ => By_copy + | Tunion _ _ => By_copy +end. + | assign_loc_value: forall v chunk m', + access_mode ty = By_value chunk -> + Mem.storev chunk m (Vptr b ofs) v cp = Some m' -> + assign_loc ce cp ty m b ofs Full v m' + +Inductive memval_inject (f : meminj) : memval -> memval -> Prop := + memval_inject_byte : forall n : byte, memval_inject f (Byte n) (Byte n) + | memval_inject_frag : forall (v1 v2 : val) (q : quantity) (n : nat), Val.inject f v1 v2 -> memval_inject f (Fragment v1 q n) (Fragment v2 q n) + | memval_inject_undef : forall mv : memval, memval_inject f Undef mv. + +Mem.storev_mapped_inject: + forall (f : meminj) (chunk : memory_chunk) (m1 : mem) (a1 v1 : val) (cp : compartment) (n1 m2 : mem) (a2 v2 : val), + Mem.inject f m1 m2 -> Mem.storev chunk m1 a1 v1 cp = Some n1 -> Val.inject f a1 a2 -> Val.inject f v1 v2 -> exists n2 : mem, Mem.storev chunk m2 a2 v2 cp = Some n2 /\ Mem.inject f n1 n2 + +| assign_loc_value: forall v chunk m', + access_mode ty = By_value chunk -> + Mem.storev chunk m (Vptr b ofs) v cp = Some m' -> + assign_loc ce cp ty m b ofs Full v m' + + +Mem.store = +fun (chunk : memory_chunk) (m : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) => +match Mem.valid_access_dec m chunk b ofs Writable (Some cp) with +| left x => + Some + {| + Mem.mem_contents := PMap.set b (Mem.setN (encode_val chunk v) ofs (Mem.mem_contents m) !! b) (Mem.mem_contents m); + Mem.mem_access := Mem.mem_access m; + Mem.mem_compartments := Mem.mem_compartments m; + Mem.nextblock := Mem.nextblock m; + Mem.access_max := + (fun (chunk0 : memory_chunk) (m0 : mem) (b0 : block) (ofs0 : Z) (_ : val) (cp0 : compartment) (_ : Mem.valid_access m0 chunk0 b0 ofs0 Writable (Some cp0)) (b1 : positive) (ofs1 : Z) => + Memory.Mem.store_obligation_1 m0 b1 ofs1) chunk m b ofs v cp x; + Mem.nextblock_noaccess := + (fun (chunk0 : memory_chunk) (m0 : mem) (b0 : block) (ofs0 : Z) (_ : val) (cp0 : compartment) (_ : Mem.valid_access m0 chunk0 b0 ofs0 Writable (Some cp0)) (b1 : positive) + (ofs1 : Z) (k : perm_kind) (H0 : ~ Plt b1 (Mem.nextblock m0)) => Memory.Mem.store_obligation_2 m0 b1 ofs1 k H0) chunk m b ofs v cp x; + Mem.contents_default := + (fun (chunk0 : memory_chunk) (m0 : mem) (b0 : block) (ofs0 : Z) (v0 : val) (cp0 : compartment) (_ : Mem.valid_access m0 chunk0 b0 ofs0 Writable (Some cp0)) (b1 : positive) => + Memory.Mem.store_obligation_3 chunk0 m0 b0 ofs0 v0 b1) chunk m b ofs v cp x; + Mem.nextblock_compartments := + (fun (chunk0 : memory_chunk) (m0 : mem) (b0 : block) (ofs0 : Z) (_ : val) (cp0 : compartment) (_ : Mem.valid_access m0 chunk0 b0 ofs0 Writable (Some cp0)) (b1 : positive) => + Memory.Mem.store_obligation_4 m0 b1) chunk m b ofs v cp x + |} +| right _ => None +end + : memory_chunk -> mem -> block -> Z -> val -> compartment -> option mem + + +End MEMDATA. + + Section IR. - Variant ir_cont_type : Type := | ir_cont: block -> signature -> ir_cont_type. + 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) := @@ -144,7 +276,7 @@ Section IR. (SIG: sg = Asm.fn_sig f_next) (TR: call_trace_vr ge cp cp' b vargs (sig_args sg) tr id evargs) : - ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg) (Some (b, m1, (ir_cont cur sg) :: ik)) + ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg) (Some (b, m1, (ir_cont cur) :: ik)) | ir_step_vr_return_internal cur m1 next ik_tl tr evretv @@ -152,7 +284,7 @@ Section IR. (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 --- TODO : false? fix? *) + (* 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)) @@ -161,7 +293,7 @@ Section IR. (* internal return: memory changes in Clight-side, so need inj-relation *) (TR: return_trace_vr ge cp_next cp_cur vretv (sig_res sg) tr evretv) : - ir_step ge (Some (cur, m1, ((ir_cont next sg) :: ik_tl))) (Bundle_return tr evretv) (Some (next, m1, ik_tl)) + ir_step ge (Some (cur, m1, ((ir_cont next) :: ik_tl))) (Bundle_return tr evretv) (Some (next, m1, ik_tl)) | ir_step_intra_call_external cur m1 m2 ik tr id evargs sg @@ -175,7 +307,7 @@ Section IR. (SIG: sg = ef_sig ef) vargs vretv (EC: external_call ef ge cp_cur vargs m1 tr vretv m2) - (LL: limit_leaks_if_unknown ef ge m1 vargs) + (LL: limit_leaks_and_unknown ef ge m1 vargs) (ARGS: evargs = vals_to_eventvals ge vargs) : ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg) (Some (cur, m2, ik)) @@ -186,7 +318,7 @@ Section IR. (CURCP: cp_cur = Genv.find_comp ge (Vptr cur Ptrofs.zero)) vargs vretv (EC: external_call ef ge cp_cur vargs m1 tr vretv m2) - (LL: limit_leaks_if_unknown ef ge m1 vargs) + (LL: limit_leaks_and_unknown ef ge m1 vargs) (ARGS: evargs = vals_to_eventvals ge vargs) : ir_step ge (Some (cur, m1, ik)) (Bundle_builtin tr ef evargs) (Some (cur, m2, ik)) @@ -223,7 +355,7 @@ Section IR. (* external function part *) tr2 m2 vretv (EC: external_call ef ge cp vargs m1 tr2 vretv m2) - (LL: limit_leaks_if_unknown ef ge m1 vargs) + (LL: limit_leaks_and_unknown ef ge m1 vargs) (ARGS: evargs = vals_to_eventvals ge vargs) : ir_step ge (Some (cur, m1, ik)) (Bundle_call (tr1 ++ tr2) id evargs sg) None @@ -244,7 +376,7 @@ Section IR. (* external function part *) tr2 m2 vretv (TR2: external_call ef ge cp vargs m1 tr2 vretv m2) - (LL: limit_leaks_if_unknown ef ge m1 vargs) + (LL: limit_leaks_and_unknown ef ge m1 vargs) (ARGS: evargs = vals_to_eventvals ge vargs) (* return part *) tr3 evretv @@ -282,16 +414,14 @@ Section AUX. End AUX. -Section ASMTOIR. +Section INVS. + + (* Definition wf_ir (ge: Asm.genv) (ist: ir_state) := *) + (* match ist with *) + (* | Some _ => True *) + (* | _ => False *) + (* end. *) - (* fix sig? *) - Definition wf_ir (ge: Asm.genv) (ist: ir_state) := - match ist with - | Some (cur, _, ik) => - match Genv.find_funct_ptr ge cur with - | Some (Internal f) => - | _ => False - end. Definition wf_stackframe (ge: Asm.genv) (fr: stackframe) := match fr with @@ -317,6 +447,7 @@ Section ASMTOIR. | _ => False end. + Definition match_cur_stack (cur: block) (ge: Asm.genv) (sk: stack) := match Genv.find_funct_ptr ge cur with | Some fd => Asm.funsig fd = sig_of_call sk @@ -329,37 +460,65 @@ Section ASMTOIR. Variant match_stackframe : ir_cont_type -> stackframe -> Prop := | match_stackframe_intro b cp sg v ofs - (* needs to talk about sig in stack *) : - match_stack_type (sf_cont b) (Stackframe b cp sg v ofs). - - - Variant match_stack_type : (sf_cont_type) -> (stackframe) -> Prop := - | match_stack_type_intro - b cp sg v ofs - (* needs to talk about sig in stack *) - : - match_stack_type (sf_cont b) (Stackframe b cp sg v ofs). - - Definition match_stack (sf: sf_conts) (st: stack) := Forall2 match_stack_type sf st. - - Definition match_cp (ge: Asm.genv) (cur: block) (cp: compartment) : Prop := - Genv.find_comp ge (Vptr cur Ptrofs.zero) = cp. + match_stackframe (ir_cont b) (Stackframe b cp sg v ofs). + Definition match_stack (ik: ir_conts) (st: stack) := Forall2 match_stackframe ik st. + + (* Definition meminj_ge {F V} (ge: Genv.t F V): meminj := *) + (* fun b => match Genv.invert_symbol ge b with *) + (* | Some id => match Genv.find_symbol ge id with *) + (* | Some b' => Some (b', 0) *) + (* | None => None *) + (* end *) + (* | None => None *) + (* end. *) + + Definition match_mem (ge: Asm.genv) (m_asm m_ir: mem): Prop := Mem.inject (meminj_public ge) m_asm m_ir. + + Definition match_state (ge: Asm.genv) (ast: Asm.state) (ist: ir_state): Prop := + match ast, ist with + | State sk rs m_a, Some (cur, m_i, ik) => + (match_cur_stack cur ge sk) /\ (match_cur_regset cur ge rs) /\ (match_stack ik sk) /\ (match_mem ge m_a m_i) + | _, _ => False + end. - Definition meminj_ge {F V} (ge: Genv.t F V): meminj := - fun b => match Genv.invert_symbol ge b with - | Some id => match Genv.find_symbol ge id with - | Some b' => Some (b', 0) - | None => None - end - | None => None - end. +End INVS. + +Inductive extcall_memcpy_sem (sz al: Z) (ge: Senv.t): + compartment -> list val -> mem -> trace -> val -> mem -> Prop := + | extcall_memcpy_sem_intro: forall c bdst odst bsrc osrc m bytes m', + al = 1 \/ al = 2 \/ al = 4 \/ al = 8 -> sz >= 0 -> (al | sz) -> + (sz > 0 -> (al | Ptrofs.unsigned osrc)) -> + (sz > 0 -> (al | Ptrofs.unsigned odst)) -> + bsrc <> bdst \/ Ptrofs.unsigned osrc = Ptrofs.unsigned odst + \/ Ptrofs.unsigned osrc + sz <= Ptrofs.unsigned odst + \/ Ptrofs.unsigned odst + sz <= Ptrofs.unsigned osrc -> + Mem.loadbytes m bsrc (Ptrofs.unsigned osrc) sz (Some c) = Some bytes -> + Mem.storebytes m bdst (Ptrofs.unsigned odst) bytes c = Some m' -> + extcall_memcpy_sem sz al ge c (Vptr bdst odst :: Vptr bsrc osrc :: nil) m E0 Vundef m'. - Definition match_mem (ge: Asm.genv) (m_ir m_asm: mem): Prop := Mem.inject (meminj_ge ge) m_asm m_ir. +Section AUX. + 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. -End ASMTOIR. + 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 AUX. Section INFORMATIVE. From 8d61db5af44960751ac9c7e8b9d34a8dd67940f9 Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 2 Jun 2023 16:00:14 +0200 Subject: [PATCH 062/174] WIP --- security/BtInfoAsm.v | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 6807e70297..b629c1e07c 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -65,7 +65,7 @@ Section BUNDLE. End BUNDLE. -Section AUX. +Section EVENT. Definition typ_to_eventval (ty: typ): eventval := match ty with @@ -116,11 +116,12 @@ Section AUX. Definition vals_to_eventvals (ge: Senv.t) (vs: list val): list eventval := map (val_to_eventval ge) vs. -End AUX. +End EVENT. Section MEMDATA. + (* Relational invariant for memory *) Record mem_weak_inj (f : meminj) (m1 m2 : mem) : Prop := mk_mem_weak_inj { mwi_perm : forall (b1 b2 : block) (delta ofs : Z) (k : perm_kind) (p : permission), @@ -151,6 +152,24 @@ Section MEMDATA. | None => None end. + (* Well formedness to enable correct Mem.store *) + Record mem_delta (ge: Senv.t) (m: mem): Type := + mk_mem_delta { + mem_delta_data : PTree.t (ZTree.t (memory_chunk * val * compartment)%type); + mem_dalta_writable : + forall (b: block) (ofs: Z) bd chunk v cp, + (PTree.get b mem_delta_data) = Some bd -> + (ZTree.get ofs bd) = Some (chunk, v, cp) -> + Mem.valid_access m chunk b ofs Writable (Some cp) + + }. + +Mem.store = +fun (chunk : memory_chunk) (m : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) => +match Mem.valid_access_dec m chunk b ofs Writable (Some cp) with + + block -> (option ( + Lemma memval_inject_get_store_get m m_ephemeral b ofs From 270dfd0104403b0ad35a8270db8754adbc43b5a8 Mon Sep 17 00:00:00 2001 From: ldj Date: Sun, 4 Jun 2023 14:41:12 +0200 Subject: [PATCH 063/174] WIP; defined inv --- security/BtInfoAsm.v | 318 ++++++++++++++----------------------------- 1 file changed, 104 insertions(+), 214 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index b629c1e07c..7c2ef5e303 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -10,6 +10,69 @@ Require Import Complements. Require Import BtBasics. +Section MEMDATA. + + (* Data to get injection by invoking correct Mem.store - weak inj + history = inj *) + Definition mem_delta := PTree.t (ZTree.t (memory_chunk * val * compartment)%type). + + Definition mem_delta_get (d: mem_delta) (b: block) (ofs: Z) := + match PTree.get b d with + | Some dd => ZTree.get ofs dd + | _ => None + end. + + (* Relational invariant for memory *) + Record mem_weak_inj (d: mem_delta) (f : meminj) (m1 m2 : mem) : Prop := + mk_mem_weak_inj + { mwi_perm : forall (b1 b2 : block) (delta ofs : Z) (k : perm_kind) (p : permission), + f b1 = Some (b2, delta) -> Mem.perm m1 b1 ofs k p -> Mem.perm m2 b2 (ofs + delta) k p; + mwi_own : forall (b1 b2 : block) (delta : Z) (cp : option compartment), + f b1 = Some (b2, delta) -> Mem.can_access_block m1 b1 cp -> Mem.can_access_block m2 b2 cp; + mwi_align : forall (b1 b2 : block) (delta : Z) (chunk : memory_chunk) (ofs : Z) (p : permission), + f b1 = Some (b2, delta) -> Mem.range_perm m1 b1 ofs (ofs + size_chunk chunk) Max p -> (align_chunk chunk | delta)%Z; + mwi_memval : forall (b1 : block) (ofs : Z) (b2 : block) (delta : Z), + (mem_delta_get d b1 ofs = None) -> + f b1 = Some (b2, delta) -> + (* ((Mem.mem_access m1) !! b1 ofs Cur = Some Readable) -> *) + Mem.perm m1 b1 ofs Cur Readable -> + memval_inject f (ZMap.get ofs (Mem.mem_contents m1) !! b1) (ZMap.get (ofs + delta)%Z (Mem.mem_contents m2) !! b2) }. + + Record weak_inject (d: mem_delta) (f : meminj) (m1 m2 : mem) : Prop := + mk_weak_inject + { mwi_inj : mem_weak_inj d f m1 m2; + mwi_freeblocks : forall b : block, ~ Mem.valid_block m1 b -> f b = None; + mwi_mappedblocks : forall (b b' : block) (delta : Z), f b = Some (b', delta) -> Mem.valid_block m2 b'; + mwi_no_overlap : Mem.meminj_no_overlap f m1; + mwi_representable : forall (b b' : block) (delta : Z) (ofs : ptrofs), + f b = Some (b', delta) -> + Mem.perm m1 b (Ptrofs.unsigned ofs) Max Nonempty \/ Mem.perm m1 b (Ptrofs.unsigned ofs - 1) Max Nonempty -> (delta >= 0)%Z /\ (0 <= Ptrofs.unsigned ofs + delta <= Ptrofs.max_unsigned)%Z; + mwi_perm_inv : forall (b1 : block) (ofs : Z) (b2 : block) (delta : Z) (k : perm_kind) (p : permission), + f b1 = Some (b2, delta) -> Mem.perm m2 b2 (ofs + delta) k p -> Mem.perm m1 b1 ofs k p \/ ~ Mem.perm m1 b1 ofs Max Nonempty }. + + 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 mem_apply_delta (d: mem_delta) (m: mem) : option mem. + Admitted. + + Definition mem_delta_writable (d: mem_delta) (m: mem) := + forall (b: block) (ofs: Z) chunk v cp, + mem_delta_get d b ofs = Some (chunk, v, cp) -> + Mem.valid_access m chunk b ofs Writable (Some cp). + + Definition mem_delta_respect_inj (d: mem_delta) (f: meminj) (m1 m2: mem) := + (* (mem_weak_inj d f m1 m2) -> *) + (exists m2', (mem_apply_delta d m2 = Some m2') /\ (Mem.mem_inj f m1 m2')). + + (* Memory inv = weak_inject /\ mem_delta_writable /\ mem_delta_respect_inj, meminj_public *) + +End MEMDATA. + + Section BUNDLE. (* (* ()-no event, {}-may event, when len(tr) > 1, need to consider cuts *) *) @@ -29,31 +92,21 @@ Section BUNDLE. (* . *) Variant bundle_event : Type := - (* generate a call code + other followup events *) - | Bundle_call (tr: trace) (id: ident) (args: list eventval) (sg: signature) (* call-ext-ret *) - (* generate a return code *) - | Bundle_return (tr: trace) (retv: eventval) (* ret *) - (* generate a builtin code *) - | Bundle_builtin (tr: trace) (ef: external_function) (args: list eventval) (* ext *) + (* generate a call code + other followup events; call-ext-ret *) + | Bundle_call (tr: trace) (id: ident) (args: list eventval) (sg: signature) + (d: option mem_delta) + (* generate a return code; ret *) + | Bundle_return (tr: trace) (retv: eventval) + (* generate a builtin code; ext *) + | Bundle_builtin (tr: trace) (ef: external_function) (args: list eventval) + (d: mem_delta) . Definition bundle_trace := list bundle_event. - (* Definition unbundle (be: bundle_event): trace := *) - (* match be with *) - (* | Bundle_call_ci tr _ *) - (* | Bundle_call_ce tr _ *) - (* | Bundle_call_vi tr _ *) - (* | Bundle_call_ve tr _ *) - (* | Bundle_call_ie tr _ _ *) - (* | Bundle_return_ci tr _ *) - (* | Bundle_return_vi tr _ *) - (* | Bundle_builtin tr _ => tr *) - (* end. *) - Definition unbundle (be: bundle_event): trace := match be with - | Bundle_call tr _ _ _ | Bundle_return tr _ | Bundle_builtin tr _ _ => tr + | Bundle_call tr _ _ _ _ | Bundle_return tr _ | Bundle_builtin tr _ _ _ => tr end. Fixpoint unbundle_trace (btr: bundle_trace) : trace := @@ -119,157 +172,6 @@ Section EVENT. End EVENT. -Section MEMDATA. - - (* Relational invariant for memory *) - Record mem_weak_inj (f : meminj) (m1 m2 : mem) : Prop := - mk_mem_weak_inj - { mwi_perm : forall (b1 b2 : block) (delta ofs : Z) (k : perm_kind) (p : permission), - f b1 = Some (b2, delta) -> Mem.perm m1 b1 ofs k p -> Mem.perm m2 b2 (ofs + delta) k p; - mwi_own : forall (b1 b2 : block) (delta : Z) (cp : option compartment), - f b1 = Some (b2, delta) -> Mem.can_access_block m1 b1 cp -> Mem.can_access_block m2 b2 cp; - mwi_align : forall (b1 b2 : block) (delta : Z) (chunk : memory_chunk) (ofs : Z) (p : permission), - f b1 = Some (b2, delta) -> Mem.range_perm m1 b1 ofs (ofs + size_chunk chunk) Max p -> (align_chunk chunk | delta)%Z; - mwi_memval : forall (b1 : block) (ofs : Z) (b2 : block) (delta : Z), - f b1 = Some (b2, delta) -> ((Mem.mem_access m1) !! b1 ofs Cur = Some Readable) -> - memval_inject f (ZMap.get ofs (Mem.mem_contents m1) !! b1) (ZMap.get (ofs + delta)%Z (Mem.mem_contents m2) !! b2) }. - - Record weak_inject (f : meminj) (m1 m2 : mem) : Prop := - mk_weak_inject - { mwi_inj : mem_weak_inj f m1 m2; - mwi_freeblocks : forall b : block, ~ Mem.valid_block m1 b -> f b = None; - mwi_mappedblocks : forall (b b' : block) (delta : Z), f b = Some (b', delta) -> Mem.valid_block m2 b'; - mwi_no_overlap : Mem.meminj_no_overlap f m1; - mwi_representable : forall (b b' : block) (delta : Z) (ofs : ptrofs), - f b = Some (b', delta) -> - Mem.perm m1 b (Ptrofs.unsigned ofs) Max Nonempty \/ Mem.perm m1 b (Ptrofs.unsigned ofs - 1) Max Nonempty -> (delta >= 0)%Z /\ (0 <= Ptrofs.unsigned ofs + delta <= Ptrofs.max_unsigned)%Z; - mwi_perm_inv : forall (b1 : block) (ofs : Z) (b2 : block) (delta : Z) (k : perm_kind) (p : permission), - f b1 = Some (b2, delta) -> Mem.perm m2 b2 (ofs + delta) k p -> Mem.perm m1 b1 ofs k p \/ ~ Mem.perm m1 b1 ofs Max Nonempty }. - - 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. - - (* Well formedness to enable correct Mem.store *) - Record mem_delta (ge: Senv.t) (m: mem): Type := - mk_mem_delta { - mem_delta_data : PTree.t (ZTree.t (memory_chunk * val * compartment)%type); - mem_dalta_writable : - forall (b: block) (ofs: Z) bd chunk v cp, - (PTree.get b mem_delta_data) = Some bd -> - (ZTree.get ofs bd) = Some (chunk, v, cp) -> - Mem.valid_access m chunk b ofs Writable (Some cp) - - }. - -Mem.store = -fun (chunk : memory_chunk) (m : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) => -match Mem.valid_access_dec m chunk b ofs Writable (Some cp) with - - block -> (option ( - - Lemma memval_inject_get_store_get - m m_ephemeral - b ofs - v - (GET: ZMap.get ofs (Mem.mem_contents m) !! b = v) - (STORE: Mem.store - -Mem.getN_setN_same: forall (vl : list memval) (p : Z) (c : ZMap.t memval), Mem.getN (Datatypes.length vl) p (Mem.setN vl p c) = vl - - memval_inject f (ZMap.get ofs (Mem.mem_contents m1) !! b1) (ZMap.get (ofs + delta)%Z (Mem.mem_contents m2) !! b2) }. - -Genv.alloc_global = -fun (F V : Type) (CF : has_comp F) (ge : Genv.t F V) (m : mem) (idg : ident * globdef F V) => -let (_, g) := idg in -match g with -| Gfun f => let (m1, b) := Mem.alloc m (comp_of f) 0 1 in Mem.drop_perm m1 b 0 1 Nonempty (comp_of f) -| Gvar v => - let init := gvar_init v in - let comp := gvar_comp v in - let sz := init_data_list_size init in - let (m1, b) := Mem.alloc m comp 0 sz in - match store_zeros m1 b 0 sz comp with - | Some m2 => match Genv.store_init_data_list ge m2 b 0 init comp with - | Some m3 => Mem.drop_perm m3 b 0 sz (Genv.perm_globvar v) comp - | None => None - end - | None => None - end -end - : forall F V : Type, has_comp F -> Genv.t F V -> mem -> ident * globdef F V -> option mem - -Definition access_mode (ty: type) : mode := - match ty with - | Tint I8 Signed _ => By_value Mint8signed - | Tint I8 Unsigned _ => By_value Mint8unsigned - | Tint I16 Signed _ => By_value Mint16signed - | Tint I16 Unsigned _ => By_value Mint16unsigned - | Tint I32 _ _ => By_value Mint32 - | Tint IBool _ _ => By_value Mint8unsigned - | Tlong _ _ => By_value Mint64 - | Tfloat F32 _ => By_value Mfloat32 - | Tfloat F64 _ => By_value Mfloat64 - | Tvoid => By_nothing - | Tpointer _ _ => By_value Mptr - | Tarray _ _ _ => By_reference - | Tfunction _ _ _ => By_reference - | Tstruct _ _ => By_copy - | Tunion _ _ => By_copy -end. - | assign_loc_value: forall v chunk m', - access_mode ty = By_value chunk -> - Mem.storev chunk m (Vptr b ofs) v cp = Some m' -> - assign_loc ce cp ty m b ofs Full v m' - -Inductive memval_inject (f : meminj) : memval -> memval -> Prop := - memval_inject_byte : forall n : byte, memval_inject f (Byte n) (Byte n) - | memval_inject_frag : forall (v1 v2 : val) (q : quantity) (n : nat), Val.inject f v1 v2 -> memval_inject f (Fragment v1 q n) (Fragment v2 q n) - | memval_inject_undef : forall mv : memval, memval_inject f Undef mv. - -Mem.storev_mapped_inject: - forall (f : meminj) (chunk : memory_chunk) (m1 : mem) (a1 v1 : val) (cp : compartment) (n1 m2 : mem) (a2 v2 : val), - Mem.inject f m1 m2 -> Mem.storev chunk m1 a1 v1 cp = Some n1 -> Val.inject f a1 a2 -> Val.inject f v1 v2 -> exists n2 : mem, Mem.storev chunk m2 a2 v2 cp = Some n2 /\ Mem.inject f n1 n2 - -| assign_loc_value: forall v chunk m', - access_mode ty = By_value chunk -> - Mem.storev chunk m (Vptr b ofs) v cp = Some m' -> - assign_loc ce cp ty m b ofs Full v m' - - -Mem.store = -fun (chunk : memory_chunk) (m : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) => -match Mem.valid_access_dec m chunk b ofs Writable (Some cp) with -| left x => - Some - {| - Mem.mem_contents := PMap.set b (Mem.setN (encode_val chunk v) ofs (Mem.mem_contents m) !! b) (Mem.mem_contents m); - Mem.mem_access := Mem.mem_access m; - Mem.mem_compartments := Mem.mem_compartments m; - Mem.nextblock := Mem.nextblock m; - Mem.access_max := - (fun (chunk0 : memory_chunk) (m0 : mem) (b0 : block) (ofs0 : Z) (_ : val) (cp0 : compartment) (_ : Mem.valid_access m0 chunk0 b0 ofs0 Writable (Some cp0)) (b1 : positive) (ofs1 : Z) => - Memory.Mem.store_obligation_1 m0 b1 ofs1) chunk m b ofs v cp x; - Mem.nextblock_noaccess := - (fun (chunk0 : memory_chunk) (m0 : mem) (b0 : block) (ofs0 : Z) (_ : val) (cp0 : compartment) (_ : Mem.valid_access m0 chunk0 b0 ofs0 Writable (Some cp0)) (b1 : positive) - (ofs1 : Z) (k : perm_kind) (H0 : ~ Plt b1 (Mem.nextblock m0)) => Memory.Mem.store_obligation_2 m0 b1 ofs1 k H0) chunk m b ofs v cp x; - Mem.contents_default := - (fun (chunk0 : memory_chunk) (m0 : mem) (b0 : block) (ofs0 : Z) (v0 : val) (cp0 : compartment) (_ : Mem.valid_access m0 chunk0 b0 ofs0 Writable (Some cp0)) (b1 : positive) => - Memory.Mem.store_obligation_3 chunk0 m0 b0 ofs0 v0 b1) chunk m b ofs v cp x; - Mem.nextblock_compartments := - (fun (chunk0 : memory_chunk) (m0 : mem) (b0 : block) (ofs0 : Z) (_ : val) (cp0 : compartment) (_ : Mem.valid_access m0 chunk0 b0 ofs0 Writable (Some cp0)) (b1 : positive) => - Memory.Mem.store_obligation_4 m0 b1) chunk m b ofs v cp x - |} -| right _ => None -end - : memory_chunk -> mem -> block -> Z -> val -> compartment -> option mem - - -End MEMDATA. - - Section IR. Variant ir_cont_type : Type := | ir_cont: block -> ir_cont_type. @@ -295,7 +197,7 @@ Section IR. (SIG: sg = Asm.fn_sig f_next) (TR: call_trace_vr ge cp cp' b vargs (sig_args sg) tr id evargs) : - ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg) (Some (b, m1, (ir_cont cur) :: ik)) + ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg None) (Some (b, m1, (ir_cont cur) :: ik)) | ir_step_vr_return_internal cur m1 next ik_tl tr evretv @@ -324,23 +226,27 @@ Section IR. (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_apply_delta d m1 = Some m1') vargs vretv - (EC: external_call ef ge cp_cur vargs m1 tr vretv m2) + (EC: external_call ef ge cp_cur vargs m1' tr vretv m2) (LL: limit_leaks_and_unknown ef ge m1 vargs) (ARGS: evargs = vals_to_eventvals ge vargs) : - ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg) (Some (cur, m2, ik)) + ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg (Some 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)) + d m1' + (MEM: mem_apply_delta d m1 = Some m1') vargs vretv - (EC: external_call ef ge cp_cur vargs m1 tr vretv m2) + (EC: external_call ef ge cp_cur vargs m1' tr vretv m2) (LL: limit_leaks_and_unknown ef ge m1 vargs) (ARGS: evargs = vals_to_eventvals ge vargs) : - ir_step ge (Some (cur, m1, ik)) (Bundle_builtin tr ef evargs) (Some (cur, m2, ik)) + ir_step ge (Some (cur, m1, ik)) (Bundle_builtin tr ef evargs d) (Some (cur, m2, ik)) | ir_step_vr_call_external1 (* early cut at call *) cur m1 ik @@ -356,7 +262,7 @@ Section IR. (SIG: sg = ef_sig ef) (TR: call_trace_vr ge cp cp' b vargs (sig_args sg) tr id evargs) : - ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg) None + ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg None) None | ir_step_cross_call_external2 (* early cut at call-ext_call *) cur m1 ik @@ -372,12 +278,14 @@ Section IR. (SIG: sg = ef_sig ef) (TR: call_trace_vr ge cp cp' b vargs (sig_args sg) tr1 id evargs) (* external function part *) + d m1' + (MEM: mem_apply_delta d m1 = Some m1') tr2 m2 vretv - (EC: external_call ef ge cp vargs m1 tr2 vretv m2) + (EC: external_call ef ge cp vargs m1' tr2 vretv m2) (LL: limit_leaks_and_unknown ef ge m1 vargs) (ARGS: evargs = vals_to_eventvals ge vargs) : - ir_step ge (Some (cur, m1, ik)) (Bundle_call (tr1 ++ tr2) id evargs sg) None + ir_step ge (Some (cur, m1, ik)) (Bundle_call (tr1 ++ tr2) id evargs sg (Some d)) None | ir_step_cross_call_external3 (* early cut at call-ext_call *) cur m1 ik @@ -393,8 +301,10 @@ Section IR. (SIG: sg = ef_sig ef) (TR1: call_trace_vr ge cp cp' b vargs (sig_args sg) tr1 id evargs) (* external function part *) + d m1' + (MEM: mem_apply_delta d m1 = Some m1') tr2 m2 vretv - (TR2: external_call ef ge cp vargs m1 tr2 vretv m2) + (TR2: external_call ef ge cp vargs m1' tr2 vretv m2) (LL: limit_leaks_and_unknown ef ge m1 vargs) (ARGS: evargs = vals_to_eventvals ge vargs) (* return part *) @@ -404,7 +314,7 @@ Section IR. (INTERNAL: Genv.find_funct_ptr ge cur = Some (AST.Internal f_cur)) (TR3: return_trace_vr ge cp cp' vretv (sig_res sg) tr3 evretv) : - ir_step ge (Some (cur, m1, ik)) (Bundle_call (tr1 ++ tr2 ++ tr3) id evargs sg) (Some (cur, m2, ik)). + ir_step ge (Some (cur, m1, ik)) (Bundle_call (tr1 ++ tr2 ++ tr3) id evargs sg (Some d)) (Some (cur, m2, ik)). (* we need a more precise invariant for the proof for Clight; counters, mem_inj, env, cont, state *) @@ -435,13 +345,6 @@ End AUX. Section INVS. - (* Definition wf_ir (ge: Asm.genv) (ist: ir_state) := *) - (* match ist with *) - (* | Some _ => True *) - (* | _ => False *) - (* end. *) - - Definition wf_stackframe (ge: Asm.genv) (fr: stackframe) := match fr with | Stackframe b _ _ _ _ => match Genv.find_funct_ptr ge b with @@ -476,45 +379,32 @@ Section INVS. 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). - Variant match_stackframe : ir_cont_type -> stackframe -> Prop := + Variant match_stackframe (ge: Asm.genv) : ir_cont_type -> stackframe -> Prop := | match_stackframe_intro - b cp sg v ofs + b1 b2 cp sg v ofs + (COMP: Genv.find_comp ge (Vptr b1 Ptrofs.zero) = Genv.find_comp ge (Vptr b2 Ptrofs.zero)) : - match_stackframe (ir_cont b) (Stackframe b cp sg v ofs). - Definition match_stack (ik: ir_conts) (st: stack) := Forall2 match_stackframe ik st. + match_stackframe ge (ir_cont b1) (Stackframe b2 cp sg v ofs). + Definition match_stack (ge: Asm.genv) (ik: ir_conts) (st: stack) := + Forall2 (match_stackframe ge) ik st. - (* Definition meminj_ge {F V} (ge: Genv.t F V): meminj := *) - (* fun b => match Genv.invert_symbol ge b with *) - (* | Some id => match Genv.find_symbol ge id with *) - (* | Some b' => Some (b', 0) *) - (* | None => None *) - (* end *) - (* | None => None *) - (* end. *) + Definition match_mem (ge: Asm.genv) (d: mem_delta) (m_asm m_ir: mem): Prop := + let j := meminj_public ge in + (weak_inject d j m_asm m_ir) /\ (mem_delta_writable d m_asm) /\ + (mem_delta_respect_inj d j m_asm m_ir). - Definition match_mem (ge: Asm.genv) (m_asm m_ir: mem): Prop := Mem.inject (meminj_public ge) m_asm m_ir. - Definition match_state (ge: Asm.genv) (ast: Asm.state) (ist: ir_state): Prop := + Definition match_state (ge: Asm.genv) (ast: Asm.state) (ist: ir_state) (d: mem_delta): Prop := match ast, ist with | State sk rs m_a, Some (cur, m_i, ik) => - (match_cur_stack cur ge sk) /\ (match_cur_regset cur ge rs) /\ (match_stack ik sk) /\ (match_mem ge m_a m_i) + (match_cur_stack cur ge sk) /\ (match_cur_regset cur ge rs) /\ + (match_stack ge ik sk) /\ (match_mem ge d m_a m_i) | _, _ => False end. End INVS. -Inductive extcall_memcpy_sem (sz al: Z) (ge: Senv.t): - compartment -> list val -> mem -> trace -> val -> mem -> Prop := - | extcall_memcpy_sem_intro: forall c bdst odst bsrc osrc m bytes m', - al = 1 \/ al = 2 \/ al = 4 \/ al = 8 -> sz >= 0 -> (al | sz) -> - (sz > 0 -> (al | Ptrofs.unsigned osrc)) -> - (sz > 0 -> (al | Ptrofs.unsigned odst)) -> - bsrc <> bdst \/ Ptrofs.unsigned osrc = Ptrofs.unsigned odst - \/ Ptrofs.unsigned osrc + sz <= Ptrofs.unsigned odst - \/ Ptrofs.unsigned odst + sz <= Ptrofs.unsigned osrc -> - Mem.loadbytes m bsrc (Ptrofs.unsigned osrc) sz (Some c) = Some bytes -> - Mem.storebytes m bdst (Ptrofs.unsigned odst) bytes c = Some m' -> - extcall_memcpy_sem sz al ge c (Vptr bdst odst :: Vptr bsrc osrc :: nil) m E0 Vundef m'. +(* TODO: destination of memcpy should not be public glob symb *) Section AUX. From 0c6d21d9df103a357514e7ad9393b834607be004 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 29 Jun 2023 17:35:38 +0200 Subject: [PATCH 064/174] WIP --- common/Events.v | 33 +++++---- riscV/Asm.v | 166 ++++++++++++++++++++++--------------------- security/BtBasics.v | 146 ++++++++++++++++++------------------- security/BtInfoAsm.v | 71 +++++++++--------- 4 files changed, 214 insertions(+), 202 deletions(-) diff --git a/common/Events.v b/common/Events.v index c3ef9e7f2c..31d587acd9 100644 --- a/common/Events.v +++ b/common/Events.v @@ -2122,7 +2122,7 @@ Section INFORM_TRACES_PRESERVED. End INFORM_TRACES_PRESERVED. -Section LEAK. +Section VISIBLE. (* Memory location has only sequence of bytes *) Definition loc_first_order (m: mem) (b: block) (ofs: Z) : Prop := @@ -2154,33 +2154,40 @@ Section LEAK. Definition vals_public (ge: Senv.t) (ts: list typ) (vs: list val): Prop := Forall2 (val_public ge) ts vs. - Definition limit_leaks (ge: Senv.t) (m: mem) (tys: list typ) (args: list val): Prop := + 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 limit_leaks_if_unknown + 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 visible_fo_if_unknown (ef: external_function) (ge: Senv.t) (m: mem) (args: list val) : Prop := match ef with - | EF_external name cp sg => limit_leaks ge m (sig_args sg) args - | EF_builtin name sg | EF_runtime name sg => + | 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 => limit_leaks ge m (sig_args sg) args + | None => visible_fo ge m (sig_args sg) args | _ => True end - | EF_inline_asm txt sg clb => limit_leaks ge m (sig_args sg) args + | 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 | _ => True end. - Definition limit_leaks_and_unknown + Definition visible_fo_and_unknown (ef: external_function) (ge: Senv.t) (m: mem) (args: list val) : Prop := match ef with - | EF_external name cp sg => limit_leaks ge m (sig_args sg) args - | EF_builtin name sg | EF_runtime name sg => + | 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 => limit_leaks ge m (sig_args sg) args + | None => visible_fo ge m (sig_args sg) args | _ => False end - | EF_inline_asm txt sg clb => limit_leaks ge m (sig_args sg) args + | EF_inline_asm cp txt sg clb => visible_fo ge m (sig_args sg) args | _ => False end. -End LEAK. +End VISIBLE. diff --git a/riscV/Asm.v b/riscV/Asm.v index 54353a295e..2bbfe71d8a 100644 --- a/riscV/Asm.v +++ b/riscV/Asm.v @@ -1399,103 +1399,105 @@ 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'). -(* Two fixes: check sig when call CALLSIG, public & first order args when undefined external call LL *) +(* Two fixes: check sig when call CALLSIG, public & first order args when undefined external call VISFO *) 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_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' ofs')), - 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.InternalCall -> - (exists fd, Genv.find_funct_ptr ge b' = Some fd /\ sig = funsig fd)), + 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.InternalCall -> + (exists fd, Genv.find_funct_ptr ge b' = Some fd /\ sig = funsig fd)), 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 +| 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 (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 +| 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 + 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), - 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 res) -> - eval_builtin_args ge rs (rs SP) m args vargs -> - external_call ef ge (comp_of f) vargs m t vres m' -> + 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), + 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 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 res vres - (undef_regs (map preg_of (destroyed_by_builtin ef)) - (rs #X1 <- Vundef #X31 <- Vundef))) -> - (* Limit leaks when calling unknown function *) - forall (LL: limit_leaks_if_unknown 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' cp 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 cp 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 step_fixs behave like returns. So we do the same as in the [exec_step_fix_internal_return] case. *) - forall (REC_CURCOMP: Genv.find_comp_ignore_offset ge (rs PC) = callee_comp st), + (undef_regs (map preg_of (destroyed_by_builtin ef)) + (rs #X1 <- Vundef #X31 <- Vundef))) -> (* Limit leaks when calling unknown function *) - forall (LL: limit_leaks_if_unknown ef ge m args), + forall (VISFO: visible_fo_if_unknown 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 (VISFO: visible_fo_if_unknown ef ge m args), step_fix (State st rs m) t (ReturnState st rs' m'). End RELSEM. diff --git a/security/BtBasics.v b/security/BtBasics.v index ab88bf97d2..d2c1e7c128 100644 --- a/security/BtBasics.v +++ b/security/BtBasics.v @@ -4,13 +4,13 @@ Require Import AST Linking Smallstep Events Behaviors. Require Import Split. -Record syscall_properties (sem: extcall_sem) (sg: signature) : Prop := - mk_syscall_properties { - sc_args_match: - forall ge cp args m1 name evargs evres res m2, - sem ge cp args m1 (Event_syscall name evargs evres :: nil) res m2 -> - eventval_list_match ge evargs sg.(sig_args) args; - }. +(* Record syscall_properties (sem: extcall_sem) (sg: signature) : Prop := *) +(* mk_syscall_properties { *) +(* sc_args_match: *) +(* forall ge cp args m1 name evargs evres res m2, *) +(* sem ge cp args m1 (Event_syscall name evargs evres :: nil) res m2 -> *) +(* eventval_list_match ge evargs sg.(sig_args) args; *) +(* }. *) Section GENV. @@ -306,69 +306,69 @@ Section HASINIT. End HASINIT. -Section EXTCALL. - - Variant external_call_event_match_common - (ef: external_function) (ev: event) (ge: Senv.t) (cp: compartment) (m1: mem) - : val -> mem -> Prop := - | ext_match_vload - ch - (EF: ef = EF_vload ch) - id ofs evv - (EV: ev = Event_vload ch id ofs evv) - b res m2 - (SEM: volatile_load_sem ch ge cp (Vptr b ofs :: nil) m1 (ev :: nil) res m2) - : - external_call_event_match_common ef ev ge cp m1 res m2 - | ext_match_vstore - ch - (EF: ef = EF_vstore ch) - id ofs evv - (EV: ev = Event_vstore ch id ofs evv) - b argv m2 - (SEM: volatile_store_sem ch ge cp (Vptr b ofs :: argv :: nil) m1 (ev :: nil) Vundef m2) - : - external_call_event_match_common ef ev ge cp m1 Vundef m2 - | ext_match_annot - len text targs - (EF: ef = EF_annot len text targs) - evargs - (EV: ev = Event_annot text evargs) - vargs m2 - (SEM: extcall_annot_sem text targs ge cp vargs m1 (ev :: nil) Vundef m2) - : - external_call_event_match_common ef ev ge cp m1 Vundef m2 - | ext_match_external - name excp sg - (EF: ef = EF_external name excp sg) - evname evargs evres - (EV: ev = Event_syscall evname evargs evres) - vargs vres m2 - (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) - (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) - : - external_call_event_match_common ef ev ge cp m1 vres m2 - | ext_match_builtin - name sg - (EF: (ef = EF_builtin name sg) \/ (ef = EF_runtime name sg)) - evname evargs evres - (EV: ev = Event_syscall evname evargs evres) - (ISEXT: Builtins.lookup_builtin_function name sg = None) - vargs vres m2 - (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) - (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) - : - external_call_event_match_common ef ev ge cp m1 vres m2 - | ext_match_inline_asm - txt sg strs - (EF: ef = EF_inline_asm txt sg strs) - evname evargs evres - (EV: ev = Event_syscall evname evargs evres) - vargs vres m2 - (SEM: inline_assembly_sem txt sg ge cp vargs m1 (ev :: nil) vres m2) - (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) - : - external_call_event_match_common ef ev ge cp m1 vres m2 - . - -End EXTCALL. +(* Section EXTCALL. *) + +(* Variant external_call_event_match_common *) +(* (ef: external_function) (ev: event) (ge: Senv.t) (cp: compartment) (m1: mem) *) +(* : val -> mem -> Prop := *) +(* | ext_match_vload *) +(* ch *) +(* (EF: ef = EF_vload ch) *) +(* id ofs evv *) +(* (EV: ev = Event_vload ch id ofs evv) *) +(* b res m2 *) +(* (SEM: volatile_load_sem ch ge cp (Vptr b ofs :: nil) m1 (ev :: nil) res m2) *) +(* : *) +(* external_call_event_match_common ef ev ge cp m1 res m2 *) +(* | ext_match_vstore *) +(* ch *) +(* (EF: ef = EF_vstore ch) *) +(* id ofs evv *) +(* (EV: ev = Event_vstore ch id ofs evv) *) +(* b argv m2 *) +(* (SEM: volatile_store_sem ch ge cp (Vptr b ofs :: argv :: nil) m1 (ev :: nil) Vundef m2) *) +(* : *) +(* external_call_event_match_common ef ev ge cp m1 Vundef m2 *) +(* | ext_match_annot *) +(* len text targs *) +(* (EF: ef = EF_annot len text targs) *) +(* evargs *) +(* (EV: ev = Event_annot text evargs) *) +(* vargs m2 *) +(* (SEM: extcall_annot_sem text targs ge cp vargs m1 (ev :: nil) Vundef m2) *) +(* : *) +(* external_call_event_match_common ef ev ge cp m1 Vundef m2 *) +(* | ext_match_external *) +(* name excp sg *) +(* (EF: ef = EF_external name excp sg) *) +(* evname evargs evres *) +(* (EV: ev = Event_syscall evname evargs evres) *) +(* vargs vres m2 *) +(* (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) *) +(* (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) *) +(* : *) +(* external_call_event_match_common ef ev ge cp m1 vres m2 *) +(* | ext_match_builtin *) +(* name sg *) +(* (EF: (ef = EF_builtin name sg) \/ (ef = EF_runtime name sg)) *) +(* evname evargs evres *) +(* (EV: ev = Event_syscall evname evargs evres) *) +(* (ISEXT: Builtins.lookup_builtin_function name sg = None) *) +(* vargs vres m2 *) +(* (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) *) +(* (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) *) +(* : *) +(* external_call_event_match_common ef ev ge cp m1 vres m2 *) +(* | ext_match_inline_asm *) +(* txt sg strs *) +(* (EF: ef = EF_inline_asm txt sg strs) *) +(* evname evargs evres *) +(* (EV: ev = Event_syscall evname evargs evres) *) +(* vargs vres m2 *) +(* (SEM: inline_assembly_sem txt sg ge cp vargs m1 (ev :: nil) vres m2) *) +(* (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) *) +(* : *) +(* external_call_event_match_common ef ev ge cp m1 vres m2 *) +(* . *) + +(* End EXTCALL. *) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 7c2ef5e303..1b0e32c2cd 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -12,52 +12,55 @@ Require Import BtBasics. Section MEMDATA. - (* Data to get injection by invoking correct Mem.store - weak inj + history = inj *) - Definition mem_delta := PTree.t (ZTree.t (memory_chunk * val * compartment)%type). - - Definition mem_delta_get (d: mem_delta) (b: block) (ofs: Z) := + (* Data to get injection by invoking correct Mem.store: inj + (apply delta) = inj *) + Definition mem_delta_data := (memory_chunk * val * compartment)%type. + Definition mem_delta_ofs := list (Z * mem_delta_data). + Definition mem_delta := PTree.t mem_delta_ofs. + + Definition mem_delta_ofs_get (dd: mem_delta_ofs) (ofs: Z): option mem_delta_data := + match find (fun '(k, data) => Z.eqb k ofs) dd with | Some (k, data) => Some data | None => None end. + Definition mem_delta_get (d: mem_delta) (b: block) (ofs: Z): option mem_delta_data := match PTree.get b d with - | Some dd => ZTree.get ofs dd + | Some dd => mem_delta_ofs_get dd ofs | _ => None end. - (* Relational invariant for memory *) - Record mem_weak_inj (d: mem_delta) (f : meminj) (m1 m2 : mem) : Prop := - mk_mem_weak_inj - { mwi_perm : forall (b1 b2 : block) (delta ofs : Z) (k : perm_kind) (p : permission), - f b1 = Some (b2, delta) -> Mem.perm m1 b1 ofs k p -> Mem.perm m2 b2 (ofs + delta) k p; - mwi_own : forall (b1 b2 : block) (delta : Z) (cp : option compartment), - f b1 = Some (b2, delta) -> Mem.can_access_block m1 b1 cp -> Mem.can_access_block m2 b2 cp; - mwi_align : forall (b1 b2 : block) (delta : Z) (chunk : memory_chunk) (ofs : Z) (p : permission), - f b1 = Some (b2, delta) -> Mem.range_perm m1 b1 ofs (ofs + size_chunk chunk) Max p -> (align_chunk chunk | delta)%Z; - mwi_memval : forall (b1 : block) (ofs : Z) (b2 : block) (delta : Z), - (mem_delta_get d b1 ofs = None) -> - f b1 = Some (b2, delta) -> - (* ((Mem.mem_access m1) !! b1 ofs Cur = Some Readable) -> *) - Mem.perm m1 b1 ofs Cur Readable -> - memval_inject f (ZMap.get ofs (Mem.mem_contents m1) !! b1) (ZMap.get (ofs + delta)%Z (Mem.mem_contents m2) !! b2) }. - - Record weak_inject (d: mem_delta) (f : meminj) (m1 m2 : mem) : Prop := - mk_weak_inject - { mwi_inj : mem_weak_inj d f m1 m2; - mwi_freeblocks : forall b : block, ~ Mem.valid_block m1 b -> f b = None; - mwi_mappedblocks : forall (b b' : block) (delta : Z), f b = Some (b', delta) -> Mem.valid_block m2 b'; - mwi_no_overlap : Mem.meminj_no_overlap f m1; - mwi_representable : forall (b b' : block) (delta : Z) (ofs : ptrofs), - f b = Some (b', delta) -> - Mem.perm m1 b (Ptrofs.unsigned ofs) Max Nonempty \/ Mem.perm m1 b (Ptrofs.unsigned ofs - 1) Max Nonempty -> (delta >= 0)%Z /\ (0 <= Ptrofs.unsigned ofs + delta <= Ptrofs.max_unsigned)%Z; - mwi_perm_inv : forall (b1 : block) (ofs : Z) (b2 : block) (delta : Z) (k : perm_kind) (p : permission), - f b1 = Some (b2, delta) -> Mem.perm m2 b2 (ofs + delta) k p -> Mem.perm m1 b1 ofs k p \/ ~ Mem.perm m1 b1 ofs Max Nonempty }. + Definition mem_delta_apply_ofs (b: block) (dd: mem_delta_ofs) (m0: mem) : option mem := + fold_left (fun om '(ofs, (ch, v, cp)) => match om with | Some m => Mem.store ch m b ofs v cp | _ => None end) dd (Some m0). + Definition mem_delta_apply (d: mem_delta) (m0: mem) : option mem := + PTree.fold (fun om b dd => match om with | Some m => mem_delta_apply_ofs b dd m | _ => None end) d (Some m0). + (* 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. + (* We keep delta only for some partial memory, as specified by some meminj *) + Definition mem_delta_wf_inj (d: mem_delta) (j: meminj): Prop := + forall b ofs dd jj, (mem_delta_get d b ofs = Some dd) -> (j b = Some jj). + + Definition mem_delta_data_fo (ddd: mem_delta_data): Prop := + let '(ch, v, cp) := ddd in Forall (fun mv => match mv with | Byte bt => True | _ => False end) (encode_val ch v). + Definition mem_delta_ofs_fo (dd: mem_delta_ofs): Prop := + Forall (fun '(k, ddd) => mem_delta_data_fo ddd) dd. + Definition mem_delta_fo (d: mem_delta): Prop := + PTree.fold (fun p b dd => p /\ (mem_delta_ofs_fo dd)) d True. + + Lemma mem_delta_apply_preserves_inj + (j: meminj) m0 m0' + (INJ0: Mem.inject j m0 m0') + (d: mem_delta) + (DWF: mem_delta_wf_inj d j) + (DFO: mem_delta_fo d) + m1 + (APPD: mem_delta_apply d m0 = Some m1) + : + exists m1', (mem_delta_apply d m0' = Some m1') /\ (Mem.inject j m1 m1'). + Proof. + Abort. - Definition mem_apply_delta (d: mem_delta) (m: mem) : option mem. - Admitted. Definition mem_delta_writable (d: mem_delta) (m: mem) := forall (b: block) (ofs: Z) chunk v cp, From 30da85aa671e06644a4402a4e9b43295f603b02c Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 30 Jun 2023 18:22:27 +0200 Subject: [PATCH 065/174] WIP --- security/BtInfoAsm.v | 190 +++++++++++++++++++++++++++++++++---------- 1 file changed, 145 insertions(+), 45 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 1b0e32c2cd..12abb66eba 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -10,70 +10,170 @@ Require Import Complements. Require Import BtBasics. -Section MEMDATA. +Section MEMDELTA. (* Data to get injection by invoking correct Mem.store: inj + (apply delta) = inj *) Definition mem_delta_data := (memory_chunk * val * compartment)%type. - Definition mem_delta_ofs := list (Z * mem_delta_data). - Definition mem_delta := PTree.t mem_delta_ofs. - - Definition mem_delta_ofs_get (dd: mem_delta_ofs) (ofs: Z): option mem_delta_data := - match find (fun '(k, data) => Z.eqb k ofs) dd with | Some (k, data) => Some data | None => None end. - Definition mem_delta_get (d: mem_delta) (b: block) (ofs: Z): option mem_delta_data := - match PTree.get b d with - | Some dd => mem_delta_ofs_get dd ofs - | _ => None - end. + Definition mem_delta_bytes := ((list memval) * compartment)%type. - Definition mem_delta_apply_ofs (b: block) (dd: mem_delta_ofs) (m0: mem) : option mem := - fold_left (fun om '(ofs, (ch, v, cp)) => match om with | Some m => Mem.store ch m b ofs v cp | _ => None end) dd (Some m0). - Definition mem_delta_apply (d: mem_delta) (m0: mem) : option mem := - PTree.fold (fun om b dd => match om with | Some m => mem_delta_apply_ofs b dd m | _ => None end) d (Some m0). + Inductive mem_delta_kind := + | mem_delta_kind_data (d: mem_delta_data) + | mem_delta_kind_bytes (d: mem_delta_bytes) + . - (* 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 mem_delta_key := (block * Z)%type. + Definition mem_delta := list (mem_delta_key * mem_delta_kind). - (* We keep delta only for some partial memory, as specified by some meminj *) - Definition mem_delta_wf_inj (d: mem_delta) (j: meminj): Prop := - forall b ofs dd jj, (mem_delta_get d b ofs = Some dd) -> (j b = Some jj). + Definition mem_delta_key_eqb (k1 k2: mem_delta_key): bool := + let (b1, ofs1) := k1 in let (b2, ofs2) := k2 in andb (Pos.eqb b1 b2) (Z.eqb ofs1 ofs2). - Definition mem_delta_data_fo (ddd: mem_delta_data): Prop := - let '(ch, v, cp) := ddd in Forall (fun mv => match mv with | Byte bt => True | _ => False end) (encode_val ch v). - Definition mem_delta_ofs_fo (dd: mem_delta_ofs): Prop := - Forall (fun '(k, ddd) => mem_delta_data_fo ddd) dd. - Definition mem_delta_fo (d: mem_delta): Prop := - PTree.fold (fun p b dd => p /\ (mem_delta_ofs_fo dd)) d True. + Definition mem_delta_get (d: mem_delta) (b: block) (ofs: Z): option mem_delta_kind := + match find (fun '(k, data) => mem_delta_key_eqb k (b, ofs)) d with | Some (k, data) => Some data | None => None end. + + Definition mem_delta_apply (d: mem_delta) (m0: mem) : option mem := + fold_right (fun '((b, ofs), data) om => + match om with + | Some m => + match data with + | mem_delta_kind_data (ch, v, cp) => Mem.store ch m b ofs v cp + | mem_delta_kind_bytes (mvs, cp) => Mem.storebytes m b ofs mvs cp + end + | None => None end) (Some m0) d. + + (* Delta and injection relation *) + Definition mem_delta_wf_inj (j: meminj): mem_delta -> Prop := + fun d => Forall (fun '((b, _), data) => + match j b with + | Some _ => (match data with | mem_delta_kind_data _ => True | _ => False end) + (* | Some (b', ofs') => (b' = b) /\ (ofs' = 0%Z) /\ (match data with | mem_delta_kind_data _ => True | _ => False end) *) + | None => True + end) d. + + Definition mem_delta_data_fo (dd: mem_delta_data): Prop := + let '(ch, v, cp) := dd in Forall (fun mv => match mv with | Byte bt => True | _ => False end) (encode_val ch v). + Definition mem_delta_fo (j: meminj) (d: mem_delta): Prop := + Forall (fun '((b, _), data) => + match j b with + | Some _ => match data with | mem_delta_kind_data dd => mem_delta_data_fo dd | _ => False end + | None => True + end) d. + + Definition mem_delta_apply_inj (j: meminj) (d: mem_delta) (m0: mem) : option mem := + fold_right (fun '((b, ofs), data) om => + match om with + | Some m => + match j b with + | Some (b', ofsd) => + match data with + | mem_delta_kind_data (ch, v, cp) => Mem.store ch m b' (ofs + ofsd) v cp + | mem_delta_kind_bytes _ => None + end + | None => om + end + | None => None + end) (Some m0) d. Lemma mem_delta_apply_preserves_inj (j: meminj) m0 m0' (INJ0: Mem.inject j m0 m0') (d: mem_delta) - (DWF: mem_delta_wf_inj d j) - (DFO: mem_delta_fo d) + (DWF: mem_delta_wf_inj j d) + (DFO: mem_delta_fo j d) m1 (APPD: mem_delta_apply d m0 = Some m1) : - exists m1', (mem_delta_apply d m0' = Some m1') /\ (Mem.inject j m1 m1'). + exists m1', (mem_delta_apply_inj j d m0' = Some m1') /\ (Mem.inject j m1 m1'). Proof. - Abort. - - - Definition mem_delta_writable (d: mem_delta) (m: mem) := - forall (b: block) (ofs: Z) chunk v cp, - mem_delta_get d b ofs = Some (chunk, v, cp) -> - Mem.valid_access m chunk b ofs Writable (Some cp). + move d after j. revert j m0 m0' INJ0 DWF DFO m1 APPD. induction d; simpl; intros. + { inv APPD. exists m0'. split; auto. } + destruct a as ((b & ofs) & kind). destruct (mem_delta_apply d m0) eqn:DAM. + 2:{ inv APPD. } + inv DWF. rename H1 into DWF1, H2 into DWF0. inv DFO. rename H1 into DFO1, H2 into DFO0. + specialize (IHd _ _ _ INJ0 DWF0 DFO0 _ DAM). destruct IHd as (m_i' & DAM' & INJ_I). rename m into m_i. rewrite DAM'. + destruct (j b) eqn:JB. + 2:{ exists m_i'. split; auto. destruct kind. + - destruct d0 as (p & cp), p as (ch, v). eapply Mem.store_unmapped_inject; eauto. + - destruct d0 as (mvs & cp). eapply Mem.storebytes_unmapped_inject; eauto. + } + destruct kind; [|contradiction]. + destruct p as (b', ofsd). destruct d0 as (p & cp), p as (ch, v). eapply Mem.store_mapped_inject; eauto. + clear - DFO1. destruct v; auto. exfalso. simpl in *. destruct Archi.ptr64. + - destruct ch; simpl in *; try (inv DFO1; contradiction). + - destruct ch; simpl in *; try (inv DFO1; contradiction). + Qed. - Definition mem_delta_respect_inj (d: mem_delta) (f: meminj) (m1 m2: mem) := - (* (mem_weak_inj d f m1 m2) -> *) - (exists m2', (mem_apply_delta d m2 = Some m2') /\ (Mem.mem_inj f m1 m2')). +(* Lemma mem_store_neq_comm *) +(* m *) +(* ch0 b0 ofs0 v0 cp0 m0 *) +(* (STORE0: Mem.store ch0 m b0 ofs0 v0 cp0 = Some m0) *) +(* ch1 b1 ofs1 v1 cp1 m1 *) +(* (STORE1: Mem.store ch1 m0 b1 ofs1 v1 cp1 = Some m1) *) +(* (NEQ: b0 <> b1) *) +(* : *) +(* exists m_i, (Mem.store ch1 m b1 ofs1 v1 cp1 = Some m_i) /\ (Mem.store ch0 m_i b0 ofs0 v0 cp0 = Some m1). *) +(* Proof. *) +(* assert (VA: Mem.valid_access m ch1 b1 ofs1 Writable (Some cp1)). *) +(* { eapply Mem.store_valid_access_2; eauto. eapply Mem.store_valid_access_3; eauto. } *) +(* eapply Mem.valid_access_store in VA. eapply ex_of_sig in VA. destruct VA as (m_i & STORE_I). exists m_i. split; eauto. *) + + +(* eapply STORE1. *) + + +(* Mem.store_valid_access_1: *) +(* forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) (m2 : mem), *) +(* Mem.store chunk m1 b ofs v cp = Some m2 -> *) +(* forall (chunk' : memory_chunk) (b' : block) (ofs' : Z) (p : permission) (cp' : option compartment), Mem.valid_access m1 chunk' b' ofs' p cp' -> Mem.valid_access m2 chunk' b' ofs' p cp' *) +(* Mem.store_valid_access_2: *) +(* forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) (m2 : mem), *) +(* Mem.store chunk m1 b ofs v cp = Some m2 -> *) +(* forall (chunk' : memory_chunk) (b' : block) (ofs' : Z) (p : permission) (cp' : option compartment), Mem.valid_access m2 chunk' b' ofs' p cp' -> Mem.valid_access m1 chunk' b' ofs' p cp' *) +(* Mem.store_valid_access_3: *) +(* forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) (m2 : mem), Mem.store chunk m1 b ofs v cp = Some m2 -> Mem.valid_access m1 chunk b ofs Writable (Some cp) *) +(* Mem.valid_access_store: *) +(* forall (m1 : mem) (chunk : memory_chunk) (b : block) (ofs : Z) (cp : compartment) (v : val), Mem.valid_access m1 chunk b ofs Writable (Some cp) -> {m2 : mem | Mem.store chunk m1 b ofs v cp = Some m2} *) +(* ex_of_sig: forall [A : Type] [P : A -> Prop], {x : A | P x} -> exists y, P y *) + +(* unfold Mem.store in *. *) +(* APPD : Mem.store ch0 m b0 ofs0 v0 cp0 = Some m1 *) +(* STORE : Mem.store ch m1 b ofs v cp = Some m2 *) + + + (* Lemma mem_delta_inv_unmapped *) + (* (j: meminj) m0 m0' *) + (* (INJ0: Mem.inject j m0 m0') *) + (* (d: mem_delta) *) + (* (DWF: mem_delta_wf_inj j d) *) + (* m1 *) + (* (APPD: mem_delta_apply d m0 = Some m1) *) + (* ch b ofs v cp m2 *) + (* (STORE: Mem.store ch m1 b ofs v cp = Some m2) *) + (* (UNMAPPED: j b = None) *) + (* : *) + (* exists m_i0, (Mem.inject j m_i0 m0') /\ (mem_delta_apply d m_i0 = Some m2). *) + (* Proof. *) + (* revert j m0 m0' INJ0 DWF m1 APPD ch b ofs v cp m2 STORE UNMAPPED. induction d; simpl; intros. *) + (* { inv APPD. exists m2. split; auto. eapply Mem.store_unmapped_inject; eauto. } *) + (* destruct a as ((b0 & ofs0) & ((ch0 & v0) & cp0)). destruct (mem_delta_apply d m0) eqn:DAM. *) + (* 2:{ inv APPD. } *) + (* inv DWF. rename H1 into DWF1, H2 into DWF0. *) + (* specialize (IHd _ _ _ INJ0 DWF0 _ DAM). *) + (* (* TODO: store commutes *) *) + + (* destruct IHd as (m_i' & DAM' & INJ_I). rewrite DAM'. rename m into m_i. *) + +Mem.store_unmapped_inject: + forall (f : meminj) (chunk : memory_chunk) (m1 : mem) (b1 : block) (ofs : Z) (v1 : val) (cp : compartment) (n1 m2 : mem), + Mem.inject f m1 m2 -> Mem.store chunk m1 b1 ofs v1 cp = Some n1 -> f b1 = None -> Mem.inject f n1 m2 - (* Memory inv = weak_inject /\ mem_delta_writable /\ mem_delta_respect_inj, meminj_public *) + (* 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. -End MEMDATA. +End MEMDELTA. Section BUNDLE. From 37e0e4456b42a46f5e8ffe4f68bee9bf770a3e72 Mon Sep 17 00:00:00 2001 From: ldj Date: Sat, 1 Jul 2023 21:28:14 +0200 Subject: [PATCH 066/174] WIP --- security/BtInfoAsm.v | 314 ++++++++++++++++++++++++++----------------- 1 file changed, 194 insertions(+), 120 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 12abb66eba..6d7d8df0ae 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -13,159 +13,233 @@ Require Import BtBasics. Section MEMDELTA. (* Data to get injection by invoking correct Mem.store: inj + (apply delta) = inj *) - Definition mem_delta_data := (memory_chunk * val * compartment)%type. - Definition mem_delta_bytes := ((list memval) * 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_data (d: mem_delta_data) + | 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) . - Definition mem_delta_key := (block * Z)%type. - Definition mem_delta := list (mem_delta_key * mem_delta_kind). + (* Definition mem_delta_key := (block * Z)%type. *) + (* Definition mem_delta := list (mem_delta_key * mem_delta_kind). *) + Definition mem_delta := list mem_delta_kind. - Definition mem_delta_key_eqb (k1 k2: mem_delta_key): bool := - let (b1, ofs1) := k1 in let (b2, ofs2) := k2 in andb (Pos.eqb b1 b2) (Z.eqb ofs1 ofs2). + (* Definition mem_delta_key_eqb (k1 k2: mem_delta_key): bool := *) + (* let (b1, ofs1) := k1 in let (b2, ofs2) := k2 in andb (Pos.eqb b1 b2) (Z.eqb ofs1 ofs2). *) - Definition mem_delta_get (d: mem_delta) (b: block) (ofs: Z): option mem_delta_kind := - match find (fun '(k, data) => mem_delta_key_eqb k (b, ofs)) d with | Some (k, data) => Some data | None => None end. + (* Definition mem_delta_get (d: mem_delta) (b: block) (ofs: Z): option mem_delta_kind := *) + (* match find (fun '(k, data) => mem_delta_key_eqb k (b, ofs)) d with | Some (k, data) => Some data | None => None end. *) + + 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 (d: mem_delta) (m0: mem) : option mem := - fold_right (fun '((b, ofs), data) om => - match om with - | Some m => - match data with - | mem_delta_kind_data (ch, v, cp) => Mem.store ch m b ofs v cp - | mem_delta_kind_bytes (mvs, cp) => Mem.storebytes m b ofs mvs cp - end - | None => None end) (Some m0) d. + fold_right (fun data om => + match data with + | 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 + ) (Some m0) d. (* Delta and injection relation *) - Definition mem_delta_wf_inj (j: meminj): mem_delta -> Prop := - fun d => Forall (fun '((b, _), data) => - match j b with - | Some _ => (match data with | mem_delta_kind_data _ => True | _ => False end) - (* | Some (b', ofs') => (b' = b) /\ (ofs' = 0%Z) /\ (match data with | mem_delta_kind_data _ => True | _ => False end) *) - | None => True - end) d. - - Definition mem_delta_data_fo (dd: mem_delta_data): Prop := - let '(ch, v, cp) := dd in Forall (fun mv => match mv with | Byte bt => True | _ => False end) (encode_val ch v). - Definition mem_delta_fo (j: meminj) (d: mem_delta): Prop := - Forall (fun '((b, _), data) => - match j b with - | Some _ => match data with | mem_delta_kind_data dd => mem_delta_data_fo dd | _ => False end - | None => True + Definition mem_delta_kind_inj_wf (j: meminj): mem_delta_kind -> Prop := + fun data => + match data with + | 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 (j: meminj): mem_delta -> Prop := + fun d => Forall (fun data => mem_delta_kind_inj_wf j data) d. + + + Definition mem_delta_inj_store_fo (j: meminj) (data: mem_delta_store): Prop := + let '(ch, b, ofs, v, cp) := data in + match j b with + | Some _ => Forall (fun mv => match mv with | Byte bt => True | _ => False end) (encode_val ch v) + | None => True + end. + + Definition mem_delta_inj_fo (j: meminj) (d: mem_delta): Prop := + Forall (fun data => + match data with + | mem_delta_kind_store d => mem_delta_inj_store_fo j d + | _ => True end) d. Definition mem_delta_apply_inj (j: meminj) (d: mem_delta) (m0: mem) : option mem := - fold_right (fun '((b, ofs), data) om => - match om with - | Some m => + fold_right (fun data om => + match data with + | mem_delta_kind_store (ch, b, ofs, v, cp) => match j b with - | Some (b', ofsd) => - match data with - | mem_delta_kind_data (ch, v, cp) => Mem.store ch m b' (ofs + ofsd) v cp - | mem_delta_kind_bytes _ => None - end + | Some (b', ofsd) => + mem_delta_apply_store om (ch, b', (ofs + ofsd)%Z, v, cp) | None => om end - | None => None + | _ => om end) (Some m0) d. + + 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. + Lemma mem_delta_apply_preserves_inj (j: meminj) m0 m0' (INJ0: Mem.inject j m0 m0') (d: mem_delta) - (DWF: mem_delta_wf_inj j d) - (DFO: mem_delta_fo j d) + (DWF: mem_delta_inj_wf j d) + (DFO: mem_delta_inj_fo j d) m1 (APPD: mem_delta_apply d m0 = Some m1) : exists m1', (mem_delta_apply_inj j d m0' = Some m1') /\ (Mem.inject j m1 m1'). Proof. - move d after j. revert j m0 m0' INJ0 DWF DFO m1 APPD. induction d; simpl; intros. + revert DWF DFO m1 APPD. induction d; simpl; intros. { inv APPD. exists m0'. split; auto. } - destruct a as ((b & ofs) & kind). destruct (mem_delta_apply d m0) eqn:DAM. - 2:{ inv APPD. } inv DWF. rename H1 into DWF1, H2 into DWF0. inv DFO. rename H1 into DFO1, H2 into DFO0. - specialize (IHd _ _ _ INJ0 DWF0 DFO0 _ DAM). destruct IHd as (m_i' & DAM' & INJ_I). rename m into m_i. rewrite DAM'. - destruct (j b) eqn:JB. - 2:{ exists m_i'. split; auto. destruct kind. - - destruct d0 as (p & cp), p as (ch, v). eapply Mem.store_unmapped_inject; eauto. - - destruct d0 as (mvs & cp). eapply Mem.storebytes_unmapped_inject; eauto. + destruct (mem_delta_apply d m0) eqn:DAM. + 2:{ destruct a; + [rewrite mem_delta_apply_store_none in APPD; inv APPD + | rewrite mem_delta_apply_bytes_none in APPD; inv APPD + | rewrite mem_delta_apply_alloc_none in APPD; inv APPD + | rewrite mem_delta_apply_free_none in APPD; inv APPD]. } - destruct kind; [|contradiction]. - destruct p as (b', ofsd). destruct d0 as (p & cp), p as (ch, v). eapply Mem.store_mapped_inject; eauto. - clear - DFO1. destruct v; auto. exfalso. simpl in *. destruct Archi.ptr64. - - destruct ch; simpl in *; try (inv DFO1; contradiction). - - destruct ch; simpl in *; try (inv DFO1; contradiction). + rename m into m_i. + specialize (IHd DWF0 DFO0 _ (eq_refl)). destruct IHd as (m_i' & DAM' & INJ_I). + rewrite DAM'. + destruct a. + - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. + destruct (j b) eqn:JB. + + destruct p as (b' & ofs'). eapply Mem.store_mapped_inject; eauto. + clear - DFO1. destruct v; auto. exfalso. simpl in *. destruct Archi.ptr64. + * destruct ch; simpl in *; try (inv DFO1; contradiction). + * destruct ch; simpl in *; try (inv DFO1; contradiction). + + exists m_i'; split; auto. eapply Mem.store_unmapped_inject; eauto. + - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. + exists m_i'; split; auto. eapply Mem.storebytes_unmapped_inject; eauto. + - destruct d0 as ((cp & lo) & hi). simpl in *. + exists m_i'; split; auto. destruct (Mem.alloc m_i cp lo hi) eqn:ALLOC. simpl in *. inv APPD. + eapply alloc_left_unmapped_inject_keep; eauto. + - destruct d0 as (((b & lo) & hi) & cp). simpl in *. + exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. Qed. -(* Lemma mem_store_neq_comm *) -(* m *) -(* ch0 b0 ofs0 v0 cp0 m0 *) -(* (STORE0: Mem.store ch0 m b0 ofs0 v0 cp0 = Some m0) *) -(* ch1 b1 ofs1 v1 cp1 m1 *) -(* (STORE1: Mem.store ch1 m0 b1 ofs1 v1 cp1 = Some m1) *) -(* (NEQ: b0 <> b1) *) -(* : *) -(* exists m_i, (Mem.store ch1 m b1 ofs1 v1 cp1 = Some m_i) /\ (Mem.store ch0 m_i b0 ofs0 v0 cp0 = Some m1). *) -(* Proof. *) -(* assert (VA: Mem.valid_access m ch1 b1 ofs1 Writable (Some cp1)). *) -(* { eapply Mem.store_valid_access_2; eauto. eapply Mem.store_valid_access_3; eauto. } *) -(* eapply Mem.valid_access_store in VA. eapply ex_of_sig in VA. destruct VA as (m_i & STORE_I). exists m_i. split; eauto. *) - - -(* eapply STORE1. *) - - -(* Mem.store_valid_access_1: *) -(* forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) (m2 : mem), *) -(* Mem.store chunk m1 b ofs v cp = Some m2 -> *) -(* forall (chunk' : memory_chunk) (b' : block) (ofs' : Z) (p : permission) (cp' : option compartment), Mem.valid_access m1 chunk' b' ofs' p cp' -> Mem.valid_access m2 chunk' b' ofs' p cp' *) -(* Mem.store_valid_access_2: *) -(* forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) (m2 : mem), *) -(* Mem.store chunk m1 b ofs v cp = Some m2 -> *) -(* forall (chunk' : memory_chunk) (b' : block) (ofs' : Z) (p : permission) (cp' : option compartment), Mem.valid_access m2 chunk' b' ofs' p cp' -> Mem.valid_access m1 chunk' b' ofs' p cp' *) -(* Mem.store_valid_access_3: *) -(* forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) (m2 : mem), Mem.store chunk m1 b ofs v cp = Some m2 -> Mem.valid_access m1 chunk b ofs Writable (Some cp) *) -(* Mem.valid_access_store: *) -(* forall (m1 : mem) (chunk : memory_chunk) (b : block) (ofs : Z) (cp : compartment) (v : val), Mem.valid_access m1 chunk b ofs Writable (Some cp) -> {m2 : mem | Mem.store chunk m1 b ofs v cp = Some m2} *) -(* ex_of_sig: forall [A : Type] [P : A -> Prop], {x : A | P x} -> exists y, P y *) - -(* unfold Mem.store in *. *) -(* APPD : Mem.store ch0 m b0 ofs0 v0 cp0 = Some m1 *) -(* STORE : Mem.store ch m1 b ofs v cp = Some m2 *) - - - (* Lemma mem_delta_inv_unmapped *) - (* (j: meminj) m0 m0' *) - (* (INJ0: Mem.inject j m0 m0') *) - (* (d: mem_delta) *) - (* (DWF: mem_delta_wf_inj j d) *) - (* m1 *) - (* (APPD: mem_delta_apply d m0 = Some m1) *) - (* ch b ofs v cp m2 *) - (* (STORE: Mem.store ch m1 b ofs v cp = Some m2) *) - (* (UNMAPPED: j b = None) *) - (* : *) - (* exists m_i0, (Mem.inject j m_i0 m0') /\ (mem_delta_apply d m_i0 = Some m2). *) - (* Proof. *) - (* revert j m0 m0' INJ0 DWF m1 APPD ch b ofs v cp m2 STORE UNMAPPED. induction d; simpl; intros. *) - (* { inv APPD. exists m2. split; auto. eapply Mem.store_unmapped_inject; eauto. } *) - (* destruct a as ((b0 & ofs0) & ((ch0 & v0) & cp0)). destruct (mem_delta_apply d m0) eqn:DAM. *) - (* 2:{ inv APPD. } *) - (* inv DWF. rename H1 into DWF1, H2 into DWF0. *) - (* specialize (IHd _ _ _ INJ0 DWF0 _ DAM). *) - (* (* TODO: store commutes *) *) - - (* destruct IHd as (m_i' & DAM' & INJ_I). rewrite DAM'. rename m into m_i. *) - -Mem.store_unmapped_inject: - forall (f : meminj) (chunk : memory_chunk) (m1 : mem) (b1 : block) (ofs : Z) (v1 : val) (cp : compartment) (n1 m2 : mem), - Mem.inject f m1 m2 -> Mem.store chunk m1 b1 ofs v1 cp = Some n1 -> f b1 = None -> Mem.inject f n1 m2 - (* 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 From 6597668eac94a235a1e6b1e6eba7ebcb0e437721 Mon Sep 17 00:00:00 2001 From: ldj Date: Sun, 2 Jul 2023 22:37:39 +0200 Subject: [PATCH 067/174] fix ir --- security/BtInfoAsm.v | 45 +++++++++++++++++++------------------------- 1 file changed, 19 insertions(+), 26 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 6d7d8df0ae..7e2b1c2b95 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -314,16 +314,11 @@ Section EVENT. (* only virtual (default) or real (cross) cases *) Inductive call_trace_vr {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> block -> list val -> list typ -> trace -> ident -> list eventval -> Prop := - | call_trace_vr_virtual : forall (cp cp' : compartment) (b : block) (vargs : list val) (vl : list eventval) (ty : list typ) (i : ident), - Genv.type_of_call ge cp cp' = Genv.DefaultCompartmentCall -> - Genv.invert_symbol ge b = Some i -> (vl = typ_to_eventvals ty) -> call_trace_vr ge cp cp' b vargs ty E0 i vl | call_trace_vr_cross : forall (cp cp' : compartment) (b : block) (vargs : list val) (vl : list eventval) (ty : list typ) (i : ident), Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> Genv.invert_symbol ge b = Some i -> eventval_list_match ge vl ty vargs -> call_trace_vr ge cp cp' b vargs ty (Event_call cp cp' i vl :: nil) i vl. Inductive return_trace_vr {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> val -> rettype -> trace -> eventval -> Prop := - | return_trace_vr_virtual : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype), - Genv.type_of_call ge cp cp' = Genv.DefaultCompartmentCall -> (res = typ_to_eventval (proj_rettype ty)) -> return_trace_vr ge cp cp' v ty E0 res | return_trace_vr_cross : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype), Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> eventval_match ge res (proj_rettype ty) v -> return_trace_vr ge cp cp' v ty (Event_return cp cp' res :: nil) res. @@ -359,6 +354,7 @@ Section IR. Definition ir_state := option (block * mem * ir_conts)%type. + (* TODO *) Variant ir_step (ge: Asm.genv) : ir_state -> bundle_event -> ir_state -> Prop := | ir_step_vr_call_internal cur m1 ik @@ -404,10 +400,10 @@ Section IR. (INTRA: Genv.type_of_call ge cp_cur cp_ext = Genv.InternalCall) (SIG: sg = ef_sig ef) d m1' - (MEM: mem_apply_delta d m1 = Some m1') + (MEM: mem_delta_apply d m1 = Some m1') vargs vretv - (EC: external_call ef ge cp_cur vargs m1' tr vretv m2) - (LL: limit_leaks_and_unknown ef ge m1 vargs) + (EC: external_call ef ge vargs m1' tr vretv m2) + (VISFO: visible_fo_and_unknown ef ge m1 vargs) (ARGS: evargs = vals_to_eventvals ge vargs) : ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg (Some d)) (Some (cur, m2, ik)) @@ -417,10 +413,10 @@ Section IR. cp_cur (CURCP: cp_cur = Genv.find_comp ge (Vptr cur Ptrofs.zero)) d m1' - (MEM: mem_apply_delta d m1 = Some m1') + (MEM: mem_delta_apply d m1 = Some m1') vargs vretv - (EC: external_call ef ge cp_cur vargs m1' tr vretv m2) - (LL: limit_leaks_and_unknown ef ge m1 vargs) + (EC: external_call ef ge vargs m1' tr vretv m2) + (VISFO: visible_fo_and_unknown ef ge m1 vargs) (ARGS: evargs = vals_to_eventvals ge vargs) : ir_step ge (Some (cur, m1, ik)) (Bundle_builtin tr ef evargs d) (Some (cur, m2, ik)) @@ -456,10 +452,10 @@ Section IR. (TR: call_trace_vr ge cp cp' b vargs (sig_args sg) tr1 id evargs) (* external function part *) d m1' - (MEM: mem_apply_delta d m1 = Some m1') + (MEM: mem_delta_apply d m1 = Some m1') tr2 m2 vretv - (EC: external_call ef ge cp vargs m1' tr2 vretv m2) - (LL: limit_leaks_and_unknown ef ge m1 vargs) + (EC: external_call ef ge vargs m1' tr2 vretv m2) + (VISFO: visible_fo_and_unknown ef ge m1 vargs) (ARGS: evargs = vals_to_eventvals ge vargs) : ir_step ge (Some (cur, m1, ik)) (Bundle_call (tr1 ++ tr2) id evargs sg (Some d)) None @@ -479,10 +475,10 @@ Section IR. (TR1: call_trace_vr ge cp cp' b vargs (sig_args sg) tr1 id evargs) (* external function part *) d m1' - (MEM: mem_apply_delta d m1 = Some m1') + (MEM: mem_delta_apply d m1 = Some m1') tr2 m2 vretv - (TR2: external_call ef ge cp vargs m1' tr2 vretv m2) - (LL: limit_leaks_and_unknown ef ge m1 vargs) + (TR2: external_call ef ge vargs m1' tr2 vretv m2) + (VISFO: visible_fo_and_unknown ef ge m1 vargs) (ARGS: evargs = vals_to_eventvals ge vargs) (* return part *) tr3 evretv @@ -493,8 +489,6 @@ Section IR. : ir_step ge (Some (cur, m1, ik)) (Bundle_call (tr1 ++ tr2 ++ tr3) id evargs sg (Some d)) (Some (cur, m2, ik)). - (* we need a more precise invariant for the proof for Clight; counters, mem_inj, env, cont, state *) - End IR. @@ -565,23 +559,22 @@ Section INVS. Definition match_stack (ge: Asm.genv) (ik: ir_conts) (st: stack) := Forall2 (match_stackframe ge) ik st. - Definition match_mem (ge: Asm.genv) (d: mem_delta) (m_asm m_ir: mem): Prop := + Definition match_mem (ge: Senv.t) (d: mem_delta) (m0 m_i m_a: mem): Prop := let j := meminj_public ge in - (weak_inject d j m_asm m_ir) /\ (mem_delta_writable d m_asm) /\ - (mem_delta_respect_inj d j m_asm m_ir). - + (Mem.inject j m0 m_i) /\ (mem_delta_inj_wf j d) /\ + (mem_delta_apply d m0 = Some m_a). - Definition match_state (ge: Asm.genv) (ast: Asm.state) (ist: ir_state) (d: mem_delta): Prop := + Definition match_state (ge: Asm.genv) (m0: 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) => (match_cur_stack cur ge sk) /\ (match_cur_regset cur ge rs) /\ - (match_stack ge ik sk) /\ (match_mem ge d m_a m_i) + (match_stack ge ik sk) /\ (match_mem ge d m0 m_a m_i) | _, _ => False end. End INVS. -(* TODO: destination of memcpy should not be public glob symb *) Section AUX. From 9810dc93c90a299b0cd343420481ee582886d9f3 Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 12 Jul 2023 16:47:09 +0200 Subject: [PATCH 068/174] WIP --- security/BtInfoAsm.v | 110 +++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 107 insertions(+), 3 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 7e2b1c2b95..f1133c1ec2 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -354,7 +354,6 @@ Section IR. Definition ir_state := option (block * mem * ir_conts)%type. - (* TODO *) Variant ir_step (ge: Asm.genv) : ir_state -> bundle_event -> ir_state -> Prop := | ir_step_vr_call_internal cur m1 ik @@ -576,7 +575,7 @@ Section INVS. End INVS. -Section 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 @@ -597,7 +596,112 @@ Section AUX. destruct IHSTAR as (n & NEXT). exists (S n). econstructor 2. eapply H. eapply NEXT. auto. Qed. -End AUX. +End MEASURE. + + +Section PROOF. + + (* TODO *) + + (* If main is External, treat it in a different case - + the trace can start with Event_syscall, without a preceding Event_call *) + Lemma asm_to_ir + cpm ge ast ast' tr + (WFGE: wf_ge ge) + (WFASM: wf_asm ge ast) + (STAR: star (Asm.step cpm) ge ast tr ast') + ist m0 d + (MTST: match_state ge m0 d ast ist) + : + exists ist' btr, (unbundle btr = tr) /\ (star (ir_step) ge ist btr ist'). + Proof. + apply measure_istar in STAR. destruct STAR as (n & STAR). + move n before ge. revert s s' it WFGE STAR sk rs m STATE WFSK WFRS cur m_ir k MC MM MS. + pattern n. apply (well_founded_induction Nat.lt_wf_0). intros m IH. intros. + inv STAR; subst. + { constructor 1. } + rename H0 into STAR. inv H; simpl. + - assert (INTRA: Genv.find_comp ge (Vptr cur Ptrofs.zero) = Genv.find_comp_ignore_offset ge (rs' PC)). + { rewrite MC. rewrite NEXTPC, <- ALLOWED. unfold Genv.find_comp_ignore_offset. rewrite H3. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H4. auto. } + destruct (Genv.find_funct_ptr ge b') eqn:NEXTFUN. destruct f0. + + eapply IH; try reflexivity. 3: eauto. all: auto. + { unfold wf_regset_stack. rewrite NEXTPC, NEXTFUN. auto. } + { admit. (* mem *) } + + (* intra -> external *) + inv STAR. + { constructor 1. } + inv H. all: rewrite NEXTPC in H8; inv H8; rewrite NEXTFUN in H11; inv H11. + inv H0. + { (* trace ends *) + exploit external_call_trace_length. eauto. intros EVLEN. destruct t. + - simpl. constructor 1. + - destruct t; simpl in EVLEN. 2: lia. clear EVLEN. + simpl. pose proof NEXTFUN as NF0. unfold Genv.find_funct_ptr in NF0. destruct (Genv.find_def ge b0) eqn:FDB0; [|inv NF0]. destruct g; inv NF0. + exploit wf_ge_block_to_id; eauto. intros (fid & INV). + econstructor 4; try reflexivity; auto. + { admit. (* ext call sem *) } + { eauto. } + { unfold Genv.allowed_call. right; left. rewrite <- NEXTPC. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. auto. } + { unfold Genv.type_of_call. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. rewrite Pos.eqb_refl. auto. } + { constructor 1. } + } + inv H. + (* replace ((set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (rs' X1) PC) with (rs' X1) in *. *) + (* 2:{ rewrite Pregmap.gss. auto. } *) + destruct (Pos.eqb_spec (callee_comp cpm sk) (Genv.find_comp_ignore_offset ge ((set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (rs' X1) PC))). + { (* intra-return *) + clear PC_RA RESTORE_SP NO_CROSS_PTR. pose proof EV as RETEV. inv RETEV; simpl. + 2:{ exfalso. unfold Genv.type_of_call in H. rewrite <- e in H. rewrite Pos.eqb_refl in H. inv H. } + 2:{ exfalso. unfold Genv.type_of_call in H. rewrite <- e in H. rewrite Pos.eqb_refl in H. inv H. } + assert (STK: st' = sk). + { unfold update_stack_return in STUPD. rewrite <- e in STUPD. rewrite Pos.eqb_refl in STUPD. inv STUPD. auto. } + subst st'. simpl in INFO; subst. simpl. + pose proof H1 as IH_ISTAR. move IH_ISTAR after H1. inv H1. + { (* trace ends *) + exploit external_call_trace_length. eauto. intros EVLEN. destruct t. + { simpl. clear EVLEN. constructor 1. } + destruct t; simpl in EVLEN. 2: lia. clear EVLEN. + pose proof NEXTFUN as NF0. unfold Genv.find_funct_ptr in NF0. destruct (Genv.find_def ge b0) eqn:FDB0; [|inv NF0]. destruct g; inv NF0. + exploit wf_ge_block_to_id. eauto. eapply FDB0. intros (fid & INV). + eapply info_asm_sem_wf_intra_call_external; eauto. + { admit. (* ext call sem *) } + { unfold Genv.allowed_call. right; left. rewrite <- NEXTPC. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. auto. } + { unfold Genv.type_of_call. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. rewrite Pos.eqb_refl. auto. } + { constructor 1. } + } + (* now we case-analysis new PC = (rs' X1) *) + destruct (val_is_ptr_or_not (rs' X1)). + { (* not a Vptr, so booms for every step *) + rename H1 into NP. clear - H0 NP. inv H0; exfalso. all: rewrite Pregmap.gss in H3; eapply NP; eauto. + } + destruct H1 as (b2 & ofs2 & NEXTPC2). destruct (Genv.find_funct_ptr ge b2) eqn:NEXTFUN2. destruct f0. + { (* next fun is internal - done by induction *) + exploit external_call_trace_length. eauto. intros EVLEN. destruct t; simpl. + { clear EVLEN. + eapply IH. 3: eapply IH_ISTAR. all: auto. + - red. rewrite Pregmap.gss. rewrite NEXTPC2. rewrite NEXTFUN2. auto. + - rewrite Pregmap.gss in *. rewrite <- e. rewrite <- REC_CURCOMP. auto. + - admit. (* mem -> need to execute external call to maintain injection? *) + } + destruct t; simpl in *. 2:lia. clear EVLEN. + pose proof NEXTFUN as NF0. unfold Genv.find_funct_ptr in NF0. destruct (Genv.find_def ge b0) eqn:FDB0; [|inv NF0]. destruct g; inv NF0. + exploit wf_ge_block_to_id. eauto. eapply FDB0. intros (fid & INV). + eapply info_asm_sem_wf_intra_call_external; eauto. + { admit. (* ext call sem *) } + { unfold Genv.allowed_call. right; left. rewrite <- NEXTPC. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. auto. } + { unfold Genv.type_of_call. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. rewrite Pos.eqb_refl. auto. } + eapply IH. 3: eapply IH_ISTAR. all: auto. + - red. rewrite Pregmap.gss. rewrite NEXTPC2. rewrite NEXTFUN2. auto. + - rewrite Pregmap.gss in *. rewrite <- e. rewrite <- REC_CURCOMP. auto. + - admit. (* mem *) + } + { (* next fun is external; undef_caller_save_regs sets RA=Vundef, so we take extcall-step, which sets PC=RA, and after the return step, we have PC=Vundef. *) + (* TODO *) + + Abort. + + +End PROOF. Section INFORMATIVE. From 349d14be3dc0702e37608c5666ea398ac5447333 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 13 Jul 2023 15:54:49 +0200 Subject: [PATCH 069/174] WIP --- security/BtInfoAsm.v | 75 ++++++++++++++++++++++++++++++++++++++------ 1 file changed, 65 insertions(+), 10 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index f1133c1ec2..296e229ce7 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -292,6 +292,11 @@ Section BUNDLE. | nil => nil end. + Inductive istar {genv state : Type} (step : genv -> state -> 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 : bundle_event) (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. + End BUNDLE. @@ -568,7 +573,7 @@ Section INVS. match ast, ist with | State sk rs m_a, Some (cur, m_i, ik) => (match_cur_stack cur ge sk) /\ (match_cur_regset cur ge rs) /\ - (match_stack ge ik sk) /\ (match_mem ge d m0 m_a m_i) + (match_stack ge ik sk) /\ (match_mem ge d m0 m_i m_a) | _, _ => False end. @@ -601,27 +606,77 @@ End MEASURE. Section PROOF. - (* TODO *) + Ltac empty_case := do 2 eexists; split; [|constructor 1]; auto. (* If main is External, treat it in a different case - the trace can start with Event_syscall, without a preceding Event_call *) Lemma asm_to_ir - cpm ge ast ast' tr + cpm ge m0 + ast ast' tr (WFGE: wf_ge ge) (WFASM: wf_asm ge ast) (STAR: star (Asm.step cpm) ge ast tr ast') - ist m0 d + ist d (MTST: match_state ge m0 d ast ist) : - exists ist' btr, (unbundle btr = tr) /\ (star (ir_step) ge ist btr ist'). + exists btr ist', (unbundle_trace btr = tr) /\ (istar (ir_step) ge ist btr ist'). Proof. - apply measure_istar in STAR. destruct STAR as (n & STAR). - move n before ge. revert s s' it WFGE STAR sk rs m STATE WFSK WFRS cur m_ir k MC MM MS. - pattern n. apply (well_founded_induction Nat.lt_wf_0). intros m IH. intros. + apply measure_star in STAR. destruct STAR as (n & STAR). + move n before m0. revert ast ast' tr WFGE WFASM STAR ist d MTST. + pattern n. apply (well_founded_induction Nat.lt_wf_0). intros n1 IH. intros. inv STAR; subst. - { constructor 1. } + (* empty case *) + { empty_case. } rename H0 into STAR. inv H; simpl. - - assert (INTRA: Genv.find_comp ge (Vptr cur Ptrofs.zero) = Genv.find_comp_ignore_offset ge (rs' PC)). + - destruct (Genv.find_funct_ptr ge b') eqn:NEXTF. + (* no next function *) + 2:{ move STAR after NEXTF. inv STAR. + (* empty case *) + { empty_case. } + (* take a step *) + { inv H. + (* invalid *) + all: exfalso; rewrite NEXTPC in H10; inv H10; rewrite NEXTF in H11; inv H11. + } + } + destruct f0. + (* has next function --- internal *) + { assert (WFASM2: 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. + } + (* TODO: lemma for asm-step and mem_delta *) + assert (d': mem_delta). + { admit. } + assert (MTST2: match_state ge m0 d' (State st rs' m') ist). + { clear IH. unfold match_state in *. destruct ist as [[[cur m_i] ik] |]. + 2:{ inv MTST. } + destruct MTST as (MTST0 & MTST1 & MTST2 & MTST3). 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 in *. destruct MTST3 as (MEM0 & MEM1 & MEM2). split. auto. split. + + +mem_delta_apply_preserves_inj: + forall (j : meminj) (m0 m0' : mem), + Mem.inject j m0 m0' -> + forall d : mem_delta, + mem_delta_inj_wf j d -> + mem_delta_inj_fo j d -> + forall m1 : mem, mem_delta_apply d m0 = Some m1 -> exists m1' : mem, mem_delta_apply_inj j d m0' = Some m1' /\ Mem.inject j m1 m1' + +match_mem = +fun (ge : Senv.t) (d : mem_delta) (m0 m_i m_a : mem) => let j := meminj_public ge in Mem.inject j m0 m_i /\ mem_delta_inj_wf j d /\ mem_delta_apply d m0 = Some m_a + : Senv.t -> mem_delta -> mem -> mem -> mem -> Prop + + + + + unfold wf_asm in WFASM. unfold match_state in MTST. + assert (INTRA: Genv.find_comp ge (Vptr cur Ptrofs.zero) = Genv.find_comp_ignore_offset ge (rs' PC)). { rewrite MC. rewrite NEXTPC, <- ALLOWED. unfold Genv.find_comp_ignore_offset. rewrite H3. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H4. auto. } destruct (Genv.find_funct_ptr ge b') eqn:NEXTFUN. destruct f0. + eapply IH; try reflexivity. 3: eauto. all: auto. From 2b36ac076a290d855b5682f0cee6b46ded176c29 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 13 Jul 2023 16:39:03 +0200 Subject: [PATCH 070/174] WIP --- security/BtInfoAsm.v | 68 ++++++++++++++++++++++++++++++-------------- 1 file changed, 46 insertions(+), 22 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 296e229ce7..6f85c54282 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -97,6 +97,19 @@ Section MEMDELTA. end ) (Some m0) d. + Lemma mem_delta_apply_cons + d m0 m k + (MEM: mem_delta_apply d m0 = Some m) + : + mem_delta_apply (k :: d) m0 = + match k with + | mem_delta_kind_store dd => mem_delta_apply_store (Some m) dd + | mem_delta_kind_bytes dd => mem_delta_apply_bytes (Some m) dd + | mem_delta_kind_alloc dd => mem_delta_apply_alloc (Some m) dd + | mem_delta_kind_free dd => mem_delta_apply_free (Some m) dd + end. + Proof. simpl. rewrite MEM. auto. Qed. + (* Delta and injection relation *) Definition mem_delta_kind_inj_wf (j: meminj): mem_delta_kind -> Prop := fun data => @@ -604,6 +617,24 @@ Section MEASURE. End MEASURE. +Section FROMASM. + + Lemma mem_delta_exec_instr + ge f i rs m cp rs' m' + (* comp_of f ? *) + (EXEC: exec_instr ge f i rs m cp = Next rs' m') + m0 d + (DELTA0: mem_delta_inj_wf (meminj_public ge) d) + (DELTA1: mem_delta_apply d m0 = Some m) + : + exists d', (mem_delta_inj_wf (meminj_public ge) d') /\ (mem_delta_apply d' m0 = Some m'). + Proof. + (* TODO *) + Admitted. + +End FROMASM. + + Section PROOF. Ltac empty_case := do 2 eexists; split; [|constructor 1]; auto. @@ -641,40 +672,33 @@ Section PROOF. } destruct f0. (* has next function --- internal *) - { assert (WFASM2: wf_asm ge (State st rs' m')). + { 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. } - (* TODO: lemma for asm-step and mem_delta *) - assert (d': mem_delta). - { admit. } - assert (MTST2: match_state ge m0 d' (State st rs' m') ist). - { clear IH. unfold match_state in *. destruct ist as [[[cur m_i] ik] |]. - 2:{ inv MTST. } - destruct MTST as (MTST0 & MTST1 & MTST2 & MTST3). split. auto. split. + unfold match_state in MTST. destruct ist as [[[cur m_i] ik] |]. + 2:{ inv MTST. } + destruct MTST as (MTST0 & MTST1 & MTST2 & MTST3). destruct MTST3 as (MEM0 & MEM1 & MEM2). + exploit mem_delta_exec_instr. eapply H3. eapply MEM1. eapply MEM2. intros (d' & MEM1' & MEM2'). + assert (MTST': match_state ge m0 d' (State st rs' m') (Some (cur, m_i, ik))). + { clear IH. 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 in *. destruct MTST3 as (MEM0 & MEM1 & MEM2). split. auto. split. - - -mem_delta_apply_preserves_inj: - forall (j : meminj) (m0 m0' : mem), - Mem.inject j m0 m0' -> - forall d : mem_delta, - mem_delta_inj_wf j d -> - mem_delta_inj_fo j d -> - forall m1 : mem, mem_delta_apply d m0 = Some m1 -> exists m1' : mem, mem_delta_apply_inj j d m0' = Some m1' /\ Mem.inject j m1 m1' - -match_mem = -fun (ge : Senv.t) (d : mem_delta) (m0 m_i m_a : mem) => let j := meminj_public ge in Mem.inject j m0 m_i /\ mem_delta_inj_wf j d /\ mem_delta_apply d m0 = Some m_a - : Senv.t -> mem_delta -> mem -> mem -> mem -> Prop + { unfold match_mem; auto. } + } + exploit IH. 4: eapply STAR. all: auto. eapply MTST'. + intros (btr & ist' & UNTR & ISTAR). + exists btr, ist'. split; auto. + } + (* has next function --- external *) + (* OLD *) unfold wf_asm in WFASM. unfold match_state in MTST. assert (INTRA: Genv.find_comp ge (Vptr cur Ptrofs.zero) = Genv.find_comp_ignore_offset ge (rs' PC)). { rewrite MC. rewrite NEXTPC, <- ALLOWED. unfold Genv.find_comp_ignore_offset. rewrite H3. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H4. auto. } From a19966dcf96f850408fd5d9234a6f65bd9fbecf8 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 13 Jul 2023 17:23:10 +0200 Subject: [PATCH 071/174] WIP --- security/BtInfoAsm.v | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 6f85c54282..6371e26312 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -694,7 +694,16 @@ Section PROOF. exists btr, ist'. split; auto. } (* has next function --- external *) - + { move STAR after NEXTF. inv STAR. + (* empty case *) + { empty_case. } + (* take a step *) + inv H. + (* invalid *) + 1,2,3,4: rewrite NEXTPC in H10; inv H10; rewrite NEXTF in H11; inv H11. + (* external call *) + { + (* TODO *) From 2c0e05688a655bbdbbcbdef30a1344db14dfe05f Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 14 Jul 2023 16:07:19 +0200 Subject: [PATCH 072/174] WIP --- security/BtInfoAsm.v | 85 ++++++++++++++++++++++++++++++++++++++------ 1 file changed, 74 insertions(+), 11 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 6371e26312..cba3b6905f 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -417,7 +417,7 @@ Section IR. (INTRA: Genv.type_of_call ge cp_cur cp_ext = Genv.InternalCall) (SIG: sg = ef_sig ef) d m1' - (MEM: mem_delta_apply d m1 = Some m1') + (MEM: mem_delta_apply_inj (meminj_public ge) d m1 = Some m1') vargs vretv (EC: external_call ef ge vargs m1' tr vretv m2) (VISFO: visible_fo_and_unknown ef ge m1 vargs) @@ -430,7 +430,7 @@ Section IR. cp_cur (CURCP: cp_cur = Genv.find_comp ge (Vptr cur Ptrofs.zero)) d m1' - (MEM: mem_delta_apply d m1 = Some m1') + (MEM: mem_delta_apply_inj (meminj_public ge) d m1 = Some m1') vargs vretv (EC: external_call ef ge vargs m1' tr vretv m2) (VISFO: visible_fo_and_unknown ef ge m1 vargs) @@ -469,7 +469,7 @@ Section IR. (TR: call_trace_vr ge cp cp' b vargs (sig_args sg) tr1 id evargs) (* external function part *) d m1' - (MEM: mem_delta_apply d m1 = Some m1') + (MEM: mem_delta_apply_inj (meminj_public ge) d m1 = Some m1') tr2 m2 vretv (EC: external_call ef ge vargs m1' tr2 vretv m2) (VISFO: visible_fo_and_unknown ef ge m1 vargs) @@ -492,7 +492,7 @@ Section IR. (TR1: call_trace_vr ge cp cp' b vargs (sig_args sg) tr1 id evargs) (* external function part *) d m1' - (MEM: mem_delta_apply d m1 = Some m1') + (MEM: mem_delta_apply_inj (meminj_public ge) d m1 = Some m1') tr2 m2 vretv (TR2: external_call ef ge vargs m1' tr2 vretv m2) (VISFO: visible_fo_and_unknown ef ge m1 vargs) @@ -646,7 +646,7 @@ Section PROOF. ast ast' tr (WFGE: wf_ge ge) (WFASM: wf_asm ge ast) - (STAR: star (Asm.step cpm) ge ast tr ast') + (STAR: star (Asm.step_fix cpm) ge ast tr ast') ist d (MTST: match_state ge m0 d ast ist) : @@ -670,16 +670,16 @@ Section PROOF. all: exfalso; rewrite NEXTPC in H10; inv H10; rewrite NEXTF in H11; inv H11. } } + unfold match_state in MTST. destruct ist as [[[cur m_i] ik] |]. + 2:{ inv MTST. } + destruct MTST as (MTST0 & MTST1 & MTST2 & MTST3). destruct MTST3 as (MEM0 & MEM1 & MEM2). + exploit mem_delta_exec_instr. eapply H3. eapply MEM1. eapply MEM2. intros (d' & MEM1' & MEM2'). 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. } - unfold match_state in MTST. destruct ist as [[[cur m_i] ik] |]. - 2:{ inv MTST. } - destruct MTST as (MTST0 & MTST1 & MTST2 & MTST3). destruct MTST3 as (MEM0 & MEM1 & MEM2). - exploit mem_delta_exec_instr. eapply H3. eapply MEM1. eapply MEM2. intros (d' & MEM1' & MEM2'). assert (MTST': match_state ge m0 d' (State st rs' m') (Some (cur, m_i, ik))). { clear IH. split. auto. split. { unfold match_cur_regset in *. rewrite NEXTPC. rewrite <- ALLOWED. rewrite MTST1. @@ -701,8 +701,71 @@ Section PROOF. inv H. (* invalid *) 1,2,3,4: rewrite NEXTPC in H10; inv H10; rewrite NEXTF in H11; inv H11. - (* external call *) - { + (* external call & InternalCall *) + { rewrite NEXTPC in H10; inv H10. rewrite NEXTF in H11; inv H11. + 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; eauto. intros FINDSYMB. + (* reestablish meminj *) + exploit mem_delta_apply_preserves_inj. eapply MEM0. eapply MEM1'. + { admit. (* from VISFO *) } + eapply MEM2'. + intros (m1' & MEMAPPIR & MEMINJ'). + exploit external_call_mem_inject. + { admit. } + { eapply H12. } + { eapply MEMINJ'. } + { instantiate (1:=args). admit. } + intros (f' & vres' & m2' & EXTCALL' & VALINJ' & MEMINJ'2 & _ & _ & INCRINJ & _). + (* take a step *) + rename H6 into STEP1; move STEP1 after REC_CURCOMP. inv STEP1. + (* terminates *) + { exists ((Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')) :: nil). eexists. simpl. split; auto. + econstructor 2. 2: econstructor 1. 2: auto. + eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. + { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. + rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. + unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. + } + { admit. (* VISFO --- maybe case analysis first on unknowns? *) } + } + (* steps --- ReturnState *) + + + + + H1 : Genv.find_funct_ptr ge b = Some (Internal f) + ALLOWED : comp_of f = Genv.find_comp_ignore_offset ge (Vptr b0 Ptrofs.zero) + NEXTPC : rs' PC = Vptr b0 Ptrofs.zero + NEXTF : Genv.find_funct_ptr ge b0 = Some (External ef) + + +external_call_mem_inject: + forall (ef : external_function) [F V : Type] [ge : Genv.t F V] [vargs : list val] [m1 : mem] (t : trace) (vres : val) (m2 : mem) [f : block -> option (block * Z)] [m1' : mem] [vargs' : list val], + meminj_preserves_globals ge f -> + external_call ef ge vargs m1 t vres m2 -> + Mem.inject f m1 m1' -> + Val.inject_list f vargs vargs' -> + exists (f' : meminj) (vres' : val) (m2' : mem), + external_call ef ge vargs' m1' t vres' m2' /\ + Val.inject f' vres vres' /\ Mem.inject f' m2 m2' /\ Mem.unchanged_on (loc_unmapped f) m1 m2 /\ Mem.unchanged_on (loc_out_of_reach f m1) m1' m2' /\ inject_incr f f' /\ inject_separated f f' m1 m1' + + + | ir_step_intra_call_external : forall (cur : block) (m1 m2 : mem) (ik : ir_conts) (tr : trace) (id : ident) (evargs : list eventval) (sg : signature) (cp_cur : compartment), + cp_cur = Genv.find_comp ge (Vptr cur Ptrofs.zero) -> + forall (b_ext : block) (ef : external_function) (cp_ext : compartment), + Genv.find_symbol ge id = Some b_ext -> + Genv.find_funct ge (Vptr b_ext Ptrofs.zero) = Some (External ef) -> + cp_ext = comp_of ef -> + Genv.type_of_call ge cp_cur cp_ext = Genv.InternalCall -> + sg = ef_sig ef -> + forall (d : mem_delta) (m1' : mem), + mem_delta_apply d m1 = Some m1' -> + forall (vargs : list val) (vretv : val), + external_call ef ge vargs m1' tr vretv m2 -> + visible_fo_and_unknown ef ge m1 vargs -> evargs = vals_to_eventvals ge vargs -> ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg (Some d)) (Some (cur, m2, ik)) + + + (* TODO *) From 850de5230fccf71eba801156a979f63f49b5778a Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 14 Jul 2023 17:06:56 +0200 Subject: [PATCH 073/174] WIP --- security/BtInfoAsm.v | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index cba3b6905f..e17e08f8cc 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -260,6 +260,37 @@ Section MEMDELTA. | None => None end. + (* TODO: this is false --- pointers can mess around *) +(* Lemma val_inject_incr_inv *) +(* f f' v v' *) +(* (INCR: inject_incr f f') *) +(* (INJ: Val.inject f' v v') *) +(* : *) +(* Val.inject f v v'. *) +(* Proof. *) +(* inv INJ; auto. eapply Val.inject_ptr; auto. *) +(* val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' *) + + Lemma mem_inject_incr + f f' m m' + (INCR: inject_incr f f') + (INJ: Mem.inject f' m m') + : + Mem.inject f m m'. + Proof. + unfold Mem.inject in *. inv INJ. split; eauto. + - clear - INCR mi_inj. inv mi_inj. split; eauto. intros. exploit mi_memval; eauto. intros. + eapply memval_inject_incr; eauto. + + +val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' +Unusedglobproof.regset_inject_incr: forall (f f' : meminj) (rs rs' : RTL.regset), Unusedglobproof.regset_inject f rs rs' -> inject_incr f f' -> Unusedglobproof.regset_inject f' rs rs' +memval_inject_incr: forall (f f' : meminj) (v1 v2 : memval), memval_inject f v1 v2 -> inject_incr f f' -> memval_inject f' v1 v2 +Stackingproof.agree_regs_inject_incr: forall (j : meminj) (ls : Linear.locset) (rs : Mach.regset) (j' : meminj), Stackingproof.agree_regs j ls rs -> inject_incr j j' -> Stackingproof.agree_regs j' ls rs +Cminorgenproof.match_temps_invariant: forall (f f' : meminj) (le : Csharpminor.temp_env) (te : Cminor.env), Cminorgenproof.match_temps f le te -> inject_incr f f' -> Cminorgenproof.match_temps f' le te +val_inject_list_incr: forall (f1 f2 : meminj) (vl vl' : list val), inject_incr f1 f2 -> Val.inject_list f1 vl vl' -> Val.inject_list f2 vl vl' + + End MEMDELTA. From 1dc963ccbfcfb71aa70b9bc4b9b9600f252bf6d1 Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 19 Jul 2023 11:21:29 +0200 Subject: [PATCH 074/174] WIP; mem relation --- common/Events.v | 21 +- security/BtInfoAsm.v | 349 ++++++++- security/MemoryWeak.v | 1583 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 1936 insertions(+), 17 deletions(-) create mode 100644 security/MemoryWeak.v diff --git a/common/Events.v b/common/Events.v index 31d587acd9..e90e4c14a6 100644 --- a/common/Events.v +++ b/common/Events.v @@ -2137,8 +2137,7 @@ Section VISIBLE. 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) - , + (READABLE: Mem.perm m b ofs Cur Readable), loc_first_order m b ofs. Definition block_public (ge: Senv.t) (b: block): Prop := @@ -2190,4 +2189,22 @@ Section VISIBLE. | _ => False end. + + (* 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. diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index e17e08f8cc..1b5d011834 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -110,6 +110,46 @@ Section MEMDELTA. end. Proof. simpl. rewrite MEM. auto. Qed. + Definition mem_delta_apply_left (d: mem_delta) (om0: option mem) : option mem := + fold_left (fun om data => + match data with + | 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 + ) d om0. + + Lemma mem_delta_apply_left_cons + d m0 k + : + mem_delta_apply_left (k :: d) m0 = + match k with + | mem_delta_kind_store dd => mem_delta_apply_left d (mem_delta_apply_store (m0) dd) + | mem_delta_kind_bytes dd => mem_delta_apply_left d (mem_delta_apply_bytes (m0) dd) + | mem_delta_kind_alloc dd => mem_delta_apply_left d (mem_delta_apply_alloc (m0) dd) + | mem_delta_kind_free dd => mem_delta_apply_left d (mem_delta_apply_free (m0) dd) + end. + Proof. simpl. destruct k; auto. Qed. + + Lemma mem_delta_apply_left_app + d0 d1 m0 + : + mem_delta_apply_left (d0 ++ d1) m0 = mem_delta_apply_left d1 (mem_delta_apply_left d0 m0). + Proof. + revert d1 m0. induction d0; intros. + { simpl. auto. } + rewrite <- app_comm_cons. rewrite ! mem_delta_apply_left_cons. destruct a; auto. + Qed. + + Lemma mem_delta_apply_eq + d m0 + : + mem_delta_apply d m0 = mem_delta_apply_left (rev d) (Some m0). + Proof. + rewrite <- (rev_involutive d) at 1. unfold mem_delta_apply, mem_delta_apply_left. rewrite fold_left_rev_right. f_equal. + Qed. + (* Delta and injection relation *) Definition mem_delta_kind_inj_wf (j: meminj): mem_delta_kind -> Prop := fun data => @@ -122,20 +162,30 @@ Section MEMDELTA. Definition mem_delta_inj_wf (j: meminj): mem_delta -> Prop := fun d => Forall (fun data => mem_delta_kind_inj_wf j data) d. + Lemma mem_delta_inj_wf_rev + j d + : + mem_delta_inj_wf j d <-> mem_delta_inj_wf j (rev d). + Proof. + unfold mem_delta_inj_wf. split; intros. apply Forall_rev; auto. rewrite <- rev_involutive. apply Forall_rev. auto. + Qed. - Definition mem_delta_inj_store_fo (j: meminj) (data: mem_delta_store): Prop := - let '(ch, b, ofs, v, cp) := data in - match j b with - | Some _ => Forall (fun mv => match mv with | Byte bt => True | _ => False end) (encode_val ch v) - | None => True - end. + 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 mem_delta_inj_store_fo (j: meminj) (data: mem_delta_store): Prop := *) + (* let '(ch, b, ofs, v, cp) := data in *) + (* match j b with *) + (* | Some _ => Forall (fun mv => match mv with | Byte bt => True | _ => False end) (encode_val ch v) *) + (* | None => True *) + (* end. *) - Definition mem_delta_inj_fo (j: meminj) (d: mem_delta): Prop := - Forall (fun data => - match data with - | mem_delta_kind_store d => mem_delta_inj_store_fo j d - | _ => True - end) d. + (* Definition mem_delta_inj_fo (j: meminj) (d: mem_delta): Prop := *) + (* Forall (fun data => *) + (* match data with *) + (* | mem_delta_kind_store d => mem_delta_inj_store_fo j d *) + (* | _ => True *) + (* end) d. *) Definition mem_delta_apply_inj (j: meminj) (d: mem_delta) (m0: mem) : option mem := fold_right (fun data om => @@ -149,6 +199,67 @@ Section MEMDELTA. | _ => om end) (Some m0) d. + Lemma mem_delta_apply_inj_cons + j d m0 m k + (MEM: mem_delta_apply_inj j d m0 = Some m) + : + mem_delta_apply_inj j (k :: d) m0 = + match k with + | mem_delta_kind_store (ch, b, ofs, v, cp) => + match j b with Some (b', ofsd) => mem_delta_apply_store (Some m) (ch, b', (ofs + ofsd)%Z, v, cp) | None => (Some m) end + | mem_delta_kind_bytes dd + | mem_delta_kind_alloc dd + | mem_delta_kind_free dd => Some m + end. + Proof. simpl. rewrite MEM. auto. Qed. + + Definition mem_delta_apply_inj_left (j: meminj) (d: mem_delta) (om0: option mem) : option mem := + fold_left (fun om data => + match data with + | mem_delta_kind_store (ch, b, ofs, v, cp) => + match j b with + | Some (b', ofsd) => + mem_delta_apply_store om (ch, b', (ofs + ofsd)%Z, v, cp) + | None => om + end + | _ => om + end) d (om0). + + Lemma mem_delta_apply_inj_left_cons + j d m0 k + : + mem_delta_apply_inj_left j (k :: d) m0 = + match k with + | mem_delta_kind_store (ch, b, ofs, v, cp) => + match j b with + | Some (b', ofsd) => + mem_delta_apply_inj_left j d (mem_delta_apply_store m0 (ch, b', (ofs + ofsd)%Z, v, cp)) + | None => mem_delta_apply_inj_left j d m0 + end + | mem_delta_kind_bytes dd + | mem_delta_kind_alloc dd + | mem_delta_kind_free dd => mem_delta_apply_inj_left j d m0 + end. + Proof. simpl. destruct k; auto. destruct d0 as [[[[a0 a1] a2] a3] a4]. destruct (j a1); auto. destruct p. auto. Qed. + + Lemma mem_delta_apply_inj_left_app + j d0 d1 m0 + : + mem_delta_apply_inj_left j (d0 ++ d1) m0 = mem_delta_apply_inj_left j d1 (mem_delta_apply_inj_left j d0 m0). + Proof. + revert j d1 m0. induction d0; intros. + { simpl. auto. } + rewrite <- app_comm_cons. rewrite ! mem_delta_apply_inj_left_cons. destruct a; auto. + { destruct d as [[[[a0 a1] a2] a3] a4]. destruct (j a1); auto. destruct p; auto. } + Qed. + + Lemma mem_delta_apply_inj_eq + j d m0 + : + mem_delta_apply_inj j d m0 = mem_delta_apply_inj_left j (rev d) (Some m0). + Proof. + rewrite <- (rev_involutive d) at 1. unfold mem_delta_apply_inj, mem_delta_apply_inj_left. rewrite fold_left_rev_right. f_equal. + Qed. Lemma alloc_left_unmapped_inject_keep: forall f m1 m2 c lo hi m1' b1, @@ -212,6 +323,101 @@ Section MEMDELTA. intros; unfold f'; apply dec_eq_false; auto. Qed. + Lemma mem_delta_apply_preserves_full + (k j: meminj) m_i m0' + (INJ0: Mem.inject k m_i m0') + (INCR: inject_incr j k) + (d_pre d_post: mem_delta) + (DWFPRE: mem_delta_inj_wf j d_pre) + (DWFPOST: mem_delta_inj_wf j d_post) + m_m + (APPDPRE: mem_delta_apply_left d_pre (Some m_i) = Some m_m) + (WINJ: mem_weak_inject j m_m m0') + m_f + (APPDPOST: mem_delta_apply_left d_post (Some m_m) = Some m_f) + (MFO: meminj_first_order j m_f) + : + exists m1', (mem_delta_apply_inj j (d_pre ++ d_post) m0' = Some m1') /\ (Mem.inject j m_f m1'). + Proof. + + + + rewrite mem_delta_apply_eq in APPD. rewrite mem_delta_apply_inj_eq. rewrite mem_delta_inj_wf_rev in DWF. remember (rev d) as rd. clear d Heqrd. rename rd into d. + revert m0 m0' INJ0 DWF APPD. induction d; intros. + { unfold mem_delta_apply_inj_left. simpl. exists m0'. split; auto. unfold mem_delta_apply_left in APPD. simpl in APPD. inv APPD. auto. } + inv DWF. rename H1 into DWF1, H2 into DWF0. + rewrite mem_delta_apply_left_cons in APPD. rewrite mem_delta_apply_inj_left_cons. + + + + + + revert DWF DFO m1 APPD. induction d; simpl; intros. + { inv APPD. exists m0'. split; auto. } + inv DWF. rename H1 into DWF1, H2 into DWF0. inv DFO. rename H1 into DFO1, H2 into DFO0. + destruct (mem_delta_apply d m0) eqn:DAM. + 2:{ destruct a; + [rewrite mem_delta_apply_store_none in APPD; inv APPD + | rewrite mem_delta_apply_bytes_none in APPD; inv APPD + | rewrite mem_delta_apply_alloc_none in APPD; inv APPD + | rewrite mem_delta_apply_free_none in APPD; inv APPD]. + } + rename m into m_i. + specialize (IHd DWF0 DFO0 _ (eq_refl)). destruct IHd as (m_i' & DAM' & INJ_I). + rewrite DAM'. + destruct a. + - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. + destruct (j b) eqn:JB. + + destruct p as (b' & ofs'). eapply Mem.store_mapped_inject; eauto. + clear - DFO1. destruct v; auto. exfalso. simpl in *. destruct Archi.ptr64. + * destruct ch; simpl in *; try (inv DFO1; contradiction). + * destruct ch; simpl in *; try (inv DFO1; contradiction). + + exists m_i'; split; auto. eapply Mem.store_unmapped_inject; eauto. + - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. + exists m_i'; split; auto. eapply Mem.storebytes_unmapped_inject; eauto. + - destruct d0 as ((cp & lo) & hi). simpl in *. + exists m_i'; split; auto. destruct (Mem.alloc m_i cp lo hi) eqn:ALLOC. simpl in *. inv APPD. + eapply alloc_left_unmapped_inject_keep; eauto. + - destruct d0 as (((b & lo) & hi) & cp). simpl in *. + exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. + Qed. + + Lemma val_inject_incr_inv + f f' v v' + (INCR: inject_incr f f') + (INJ: Val.inject f' v v') + : + Val.inject f v v'. + Proof. + inv INJ; auto. eapply Val.inject_ptr; auto. +val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' + + Lemma mem_inject_incr + f f' m m' + (INCR: inject_incr f f') + (INJ: Mem.inject f' m m') + : + Mem.inject f m m'. + Proof. + unfold Mem.inject in *. inv INJ. split; eauto. + 2:{ intros. specialize (mi_freeblocks _ H). unfold inject_incr in INCR. + destruct (f b) eqn:FB; auto. destruct p. specialize (INCR _ _ _ FB). + rewrite INCR in mi_freeblocks. inv mi_freeblocks. + } + 2:{ clear - INCR mi_no_overlap. unfold Mem.meminj_no_overlap in *. intros. + exploit mi_no_overlap; eauto. + } + clear - INCR mi_inj. inv mi_inj. split; eauto. intros. exploit mi_memval; eauto. intros. + eapply memval_inject_incr; eauto. + ` + +val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' +Unusedglobproof.regset_inject_incr: forall (f f' : meminj) (rs rs' : RTL.regset), Unusedglobproof.regset_inject f rs rs' -> inject_incr f f' -> Unusedglobproof.regset_inject f' rs rs' +memval_inject_incr: forall (f f' : meminj) (v1 v2 : memval), memval_inject f v1 v2 -> inject_incr f f' -> memval_inject f' v1 v2 +Stackingproof.agree_regs_inject_incr: forall (j : meminj) (ls : Linear.locset) (rs : Mach.regset) (j' : meminj), Stackingproof.agree_regs j ls rs -> inject_incr j j' -> Stackingproof.agree_regs j' ls rs +Cminorgenproof.match_temps_invariant: forall (f f' : meminj) (le : Csharpminor.temp_env) (te : Cminor.env), Cminorgenproof.match_temps f le te -> inject_incr f f' -> Cminorgenproof.match_temps f' le te +val_inject_list_incr: forall (f1 f2 : meminj) (vl vl' : list val), inject_incr f1 f2 -> Val.inject_list f1 vl vl' -> Val.inject_list f2 vl vl' + Lemma mem_delta_apply_preserves_inj (j: meminj) m0 m0' (INJ0: Mem.inject j m0 m0') @@ -253,6 +459,97 @@ Section MEMDELTA. exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. Qed. + 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. + + Lemma mem_delta_apply_preserves_inj_incr + (j k: meminj) m0 m0' + (INCR: inject_incr j k) + (INJ0: Mem.inject k m0 m0') + (d: mem_delta) + (DWF: mem_delta_inj_wf j d) + (DFO: mem_delta_inj_fo j d) + m1 + (APPD: mem_delta_apply d m0 = Some m1) + (MIFO: meminj_first_order j m1) + : + exists m1', (mem_delta_apply_inj j d m0' = Some m1') /\ (Mem.inject j m1 m1'). + Proof. + revert DWF DFO m1 APPD MIFO. induction d; simpl; intros. + { inv APPD. exists m0'. split; auto. admit. (* MIFO *) } + inv DWF. rename H1 into DWF1, H2 into DWF0. inv DFO. rename H1 into DFO1, H2 into DFO0. + destruct (mem_delta_apply d m0) eqn:DAM. + 2:{ destruct a; + [rewrite mem_delta_apply_store_none in APPD; inv APPD + | rewrite mem_delta_apply_bytes_none in APPD; inv APPD + | rewrite mem_delta_apply_alloc_none in APPD; inv APPD + | rewrite mem_delta_apply_free_none in APPD; inv APPD]. + } + rename m into m_i. + specialize (IHd DWF0 DFO0 _ (eq_refl)). destruct IHd as (m_i' & DAM' & INJ_I). + { unfold meminj_first_order in *. intros. rename d into deltas. + specialize (MIFO _ ofs H). exploit MIFO; clear MIFO. + { destruct a; simpl in *. + - unfold mem_delta_apply_store in APPD. destruct d as [[[[ch0 b0] ofs0] v0] cp0]. + eapply Mem.perm_store_1; eauto. + - unfold mem_delta_apply_bytes in APPD. destruct d as [[[b0 ofs0] mvs0] cp0]. + eapply Mem.perm_storebytes_1; eauto. + - unfold mem_delta_apply_alloc in APPD. destruct d as [[cp0 lo0] hi0]. + destruct (Mem.alloc m_i cp0 lo0 hi0) eqn:CASES. inv APPD. + eapply Mem.perm_alloc_1; eauto. + - unfold mem_delta_apply_free in APPD. destruct d as [[[b0 lo0] hi0] cp0]. + eapply Mem.perm_free_1; eauto. left. intros EQ. subst. rewrite DWF1 in H. congruence. + } + intros MIFO. clear H0. + { destruct a; simpl in *. + - unfold mem_delta_apply_store in APPD. destruct d as [[[[ch0 b0] ofs0] v0] cp0]. + destruct (Pos.eqb_spec b b0). + + subst b0. unfold mem_delta_inj_store_fo in DFO1. + destruct (j b) eqn:JB. 2: congruence. clear H. destruct p. + unfold loc_first_order in *. clear MIFO APPD. + + + +Mem.store_mem_contents: + forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) + (cp : compartment) (m2 : mem), + Mem.store chunk m1 b ofs v cp = Some m2 -> + Mem.mem_contents m2 = + PMap.set b (Mem.setN (encode_val chunk v) ofs (Mem.mem_contents m1) !! b) (Mem.mem_contents m1) + + + + eapply Mem.perm_store_1; eauto. + - unfold mem_delta_apply_bytes in APPD. destruct d as [[[b0 ofs0] mvs0] cp0]. + eapply Mem.perm_storebytes_1; eauto. + - unfold mem_delta_apply_alloc in APPD. destruct d as [[cp0 lo0] hi0]. + destruct (Mem.alloc m_i cp0 lo0 hi0) eqn:CASES. inv APPD. + eapply Mem.perm_alloc_1; eauto. + - unfold mem_delta_apply_free in APPD. destruct d as [[[b0 lo0] hi0] cp0]. + eapply Mem.perm_free_1; eauto. left. intros EQ. subst. rewrite DWF1 in H. congruence. + } + + + + + rewrite DAM'. + destruct a. + - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. + destruct (j b) eqn:JB. + + destruct p as (b' & ofs'). eapply Mem.store_mapped_inject; eauto. + clear - DFO1. destruct v; auto. exfalso. simpl in *. destruct Archi.ptr64. + * destruct ch; simpl in *; try (inv DFO1; contradiction). + * destruct ch; simpl in *; try (inv DFO1; contradiction). + + exists m_i'; split; auto. eapply Mem.store_unmapped_inject; eauto. + - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. + exists m_i'; split; auto. eapply Mem.storebytes_unmapped_inject; eauto. + - destruct d0 as ((cp & lo) & hi). simpl in *. + exists m_i'; split; auto. destruct (Mem.alloc m_i cp lo hi) eqn:ALLOC. simpl in *. inv APPD. + eapply alloc_left_unmapped_inject_keep; eauto. + - destruct d0 as (((b & lo) & hi) & cp). simpl in *. + exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. + Qed. + (* 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 @@ -260,6 +557,21 @@ Section MEMDELTA. | None => None end. + + (DFO: mem_delta_inj_fo j d) + visible_fo_if_unknown ef ge m vargs -> + | None => visible_fo ge m (sig_args sg) args +visible_fo = +fun (ge : Senv.t) (m : mem) (tys : list typ) (args : list val) => +public_first_order ge m /\ vals_public ge tys args + : Senv.t -> mem -> list typ -> list val -> Prop +public_first_order = +fun (ge : Senv.t) (m : mem) => +forall (id : ident) (b : block) (ofs : Z), +Senv.public_symbol ge id = true -> +Senv.find_symbol ge id = Some b -> Mem.perm m b ofs Cur Readable -> loc_first_order m b ofs + : Senv.t -> mem -> Prop + (* TODO: this is false --- pointers can mess around *) (* Lemma val_inject_incr_inv *) (* f f' v v' *) @@ -279,9 +591,16 @@ Section MEMDELTA. Mem.inject f m m'. Proof. unfold Mem.inject in *. inv INJ. split; eauto. - - clear - INCR mi_inj. inv mi_inj. split; eauto. intros. exploit mi_memval; eauto. intros. - eapply memval_inject_incr; eauto. - + 2:{ intros. specialize (mi_freeblocks _ H). unfold inject_incr in INCR. + destruct (f b) eqn:FB; auto. destruct p. specialize (INCR _ _ _ FB). + rewrite INCR in mi_freeblocks. inv mi_freeblocks. + } + 2:{ clear - INCR mi_no_overlap. unfold Mem.meminj_no_overlap in *. intros. + exploit mi_no_overlap; eauto. + } + clear - INCR mi_inj. inv mi_inj. split; eauto. intros. exploit mi_memval; eauto. intros. + eapply memval_inject_incr; eauto. + ` val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' Unusedglobproof.regset_inject_incr: forall (f f' : meminj) (rs rs' : RTL.regset), Unusedglobproof.regset_inject f rs rs' -> inject_incr f f' -> Unusedglobproof.regset_inject f' rs rs' diff --git a/security/MemoryWeak.v b/security/MemoryWeak.v new file mode 100644 index 0000000000..2942e12228 --- /dev/null +++ b/security/MemoryWeak.v @@ -0,0 +1,1583 @@ +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) -> + Val.inject f v1 v2 -> + 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 H4) 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) -> + Val.inject f v1 v2 -> + 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 H4; 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. + + (* Lemma val_lessdef_winject_compose: *) + (* forall f v1 v2 v3, *) + (* Val.lessdef v1 v2 -> Val.inject f v2 v3 -> Val.inject f v1 v3. *) + (* Proof. *) + (* intros. inv H. auto. auto. *) + (* Qed. *) + + (* Lemma val_inject_lessdef_compose: *) + (* forall f v1 v2 v3, *) + (* Val.inject f v1 v2 -> Val.lessdef v2 v3 -> Val.inject f v1 v3. *) + (* Proof. *) + (* intros. inv H0. auto. inv H. auto. *) + (* 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 store_winject_neutral: + forall chunk m b ofs v cp m' thr, + store chunk m b ofs v cp = Some m' -> + winject_neutral thr m -> + Plt b thr -> + Val.inject (flat_winj thr) v v -> + winject_neutral thr m'. + Proof. + intros; red. + exploit store_mapped_winj. eauto. eauto. apply flat_winj_no_overlap. + unfold flat_winj. apply pred_dec_true; auto. eauto. + replace (ofs + 0) with ofs by lia. + intros [m'' [A B]]. congruence. + 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. From 49f636cdea8b72db48a273ea83b0aaf3f4aa9696 Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 19 Jul 2023 15:45:51 +0200 Subject: [PATCH 075/174] WIP --- Makefile | 2 +- security/BtInfoAsm.v | 1109 ++++++++++++++++++++-------------------- security/MemoryDelta.v | 818 +++++++++++++++++++++++++++++ 3 files changed, 1374 insertions(+), 555 deletions(-) create mode 100644 security/MemoryDelta.v diff --git a/Makefile b/Makefile index 202188b049..6e863ada20 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 BtInfoAsm.v BtBasics.v BtFromAsm.v Backtranslation.v +SECURITY=RSC.v Split.v Blame.v Recomposition.v MemoryWeak.v MemoryDelta.v BtInfoAsm.v BtBasics.v BtFromAsm.v Backtranslation.v # Parser diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 1b5d011834..2929cc6d8f 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -7,610 +7,611 @@ Require Import Split. Require Import riscV.Machregs. Require Import riscV.Asm. Require Import Complements. +Require Import MemoryWeak MemoryDelta. Require Import BtBasics. -Section MEMDELTA. +(* Section MEMDELTA. *) - (* Data to get injection by invoking correct Mem.store: inj + (apply delta) = inj *) - 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. +(* (* Data to get injection by invoking correct Mem.store: inj + (apply delta) = inj *) *) +(* 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_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) - . - - (* Definition mem_delta_key := (block * Z)%type. *) - (* Definition mem_delta := list (mem_delta_key * mem_delta_kind). *) - Definition mem_delta := list mem_delta_kind. - - (* Definition mem_delta_key_eqb (k1 k2: mem_delta_key): bool := *) - (* let (b1, ofs1) := k1 in let (b2, ofs2) := k2 in andb (Pos.eqb b1 b2) (Z.eqb ofs1 ofs2). *) - - (* Definition mem_delta_get (d: mem_delta) (b: block) (ofs: Z): option mem_delta_kind := *) - (* match find (fun '(k, data) => mem_delta_key_eqb k (b, ofs)) d with | Some (k, data) => Some data | None => None end. *) +(* Inductive mem_delta_kind := *) +(* | 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) *) +(* . *) - 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. +(* (* Definition mem_delta_key := (block * Z)%type. *) *) +(* (* Definition mem_delta := list (mem_delta_key * mem_delta_kind). *) *) +(* Definition mem_delta := list mem_delta_kind. *) - 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. +(* (* Definition mem_delta_key_eqb (k1 k2: mem_delta_key): bool := *) *) +(* (* let (b1, ofs1) := k1 in let (b2, ofs2) := k2 in andb (Pos.eqb b1 b2) (Z.eqb ofs1 ofs2). *) *) - 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 (d: mem_delta) (m0: mem) : option mem := - fold_right (fun data om => - match data with - | 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 - ) (Some m0) d. - - Lemma mem_delta_apply_cons - d m0 m k - (MEM: mem_delta_apply d m0 = Some m) - : - mem_delta_apply (k :: d) m0 = - match k with - | mem_delta_kind_store dd => mem_delta_apply_store (Some m) dd - | mem_delta_kind_bytes dd => mem_delta_apply_bytes (Some m) dd - | mem_delta_kind_alloc dd => mem_delta_apply_alloc (Some m) dd - | mem_delta_kind_free dd => mem_delta_apply_free (Some m) dd - end. - Proof. simpl. rewrite MEM. auto. Qed. - - Definition mem_delta_apply_left (d: mem_delta) (om0: option mem) : option mem := - fold_left (fun om data => - match data with - | 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 - ) d om0. +(* (* Definition mem_delta_get (d: mem_delta) (b: block) (ofs: Z): option mem_delta_kind := *) *) +(* (* match find (fun '(k, data) => mem_delta_key_eqb k (b, ofs)) d with | Some (k, data) => Some data | None => None end. *) *) - Lemma mem_delta_apply_left_cons - d m0 k - : - mem_delta_apply_left (k :: d) m0 = - match k with - | mem_delta_kind_store dd => mem_delta_apply_left d (mem_delta_apply_store (m0) dd) - | mem_delta_kind_bytes dd => mem_delta_apply_left d (mem_delta_apply_bytes (m0) dd) - | mem_delta_kind_alloc dd => mem_delta_apply_left d (mem_delta_apply_alloc (m0) dd) - | mem_delta_kind_free dd => mem_delta_apply_left d (mem_delta_apply_free (m0) dd) - end. - Proof. simpl. destruct k; 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_left_app - d0 d1 m0 - : - mem_delta_apply_left (d0 ++ d1) m0 = mem_delta_apply_left d1 (mem_delta_apply_left d0 m0). - Proof. - revert d1 m0. induction d0; intros. - { simpl. auto. } - rewrite <- app_comm_cons. rewrite ! mem_delta_apply_left_cons. destruct a; auto. - Qed. +(* 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_eq - d m0 - : - mem_delta_apply d m0 = mem_delta_apply_left (rev d) (Some m0). - Proof. - rewrite <- (rev_involutive d) at 1. unfold mem_delta_apply, mem_delta_apply_left. rewrite fold_left_rev_right. f_equal. - Qed. +(* 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. *) - (* Delta and injection relation *) - Definition mem_delta_kind_inj_wf (j: meminj): mem_delta_kind -> Prop := - fun data => - match data with - | mem_delta_kind_bytes (b, ofs, mvs, cp) => (j b) = None - | mem_delta_kind_free (b, lo, hi, cp) => (j b) = None - | _ => True - 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. *) - Definition mem_delta_inj_wf (j: meminj): mem_delta -> Prop := - fun d => Forall (fun data => mem_delta_kind_inj_wf j data) d. +(* 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 (d: mem_delta) (m0: mem) : option mem := *) +(* fold_right (fun data om => *) +(* match data with *) +(* | 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 *) +(* ) (Some m0) d. *) + +(* Lemma mem_delta_apply_cons *) +(* d m0 m k *) +(* (MEM: mem_delta_apply d m0 = Some m) *) +(* : *) +(* mem_delta_apply (k :: d) m0 = *) +(* match k with *) +(* | mem_delta_kind_store dd => mem_delta_apply_store (Some m) dd *) +(* | mem_delta_kind_bytes dd => mem_delta_apply_bytes (Some m) dd *) +(* | mem_delta_kind_alloc dd => mem_delta_apply_alloc (Some m) dd *) +(* | mem_delta_kind_free dd => mem_delta_apply_free (Some m) dd *) +(* end. *) +(* Proof. simpl. rewrite MEM. auto. Qed. *) + +(* Definition mem_delta_apply_left (d: mem_delta) (om0: option mem) : option mem := *) +(* fold_left (fun om data => *) +(* match data with *) +(* | 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 *) +(* ) d om0. *) + +(* Lemma mem_delta_apply_left_cons *) +(* d m0 k *) +(* : *) +(* mem_delta_apply_left (k :: d) m0 = *) +(* match k with *) +(* | mem_delta_kind_store dd => mem_delta_apply_left d (mem_delta_apply_store (m0) dd) *) +(* | mem_delta_kind_bytes dd => mem_delta_apply_left d (mem_delta_apply_bytes (m0) dd) *) +(* | mem_delta_kind_alloc dd => mem_delta_apply_left d (mem_delta_apply_alloc (m0) dd) *) +(* | mem_delta_kind_free dd => mem_delta_apply_left d (mem_delta_apply_free (m0) dd) *) +(* end. *) +(* Proof. simpl. destruct k; auto. Qed. *) + +(* Lemma mem_delta_apply_left_app *) +(* d0 d1 m0 *) +(* : *) +(* mem_delta_apply_left (d0 ++ d1) m0 = mem_delta_apply_left d1 (mem_delta_apply_left d0 m0). *) +(* Proof. *) +(* revert d1 m0. induction d0; intros. *) +(* { simpl. auto. } *) +(* rewrite <- app_comm_cons. rewrite ! mem_delta_apply_left_cons. destruct a; auto. *) +(* Qed. *) - Lemma mem_delta_inj_wf_rev - j d - : - mem_delta_inj_wf j d <-> mem_delta_inj_wf j (rev d). - Proof. - unfold mem_delta_inj_wf. split; intros. apply Forall_rev; auto. rewrite <- rev_involutive. apply Forall_rev. auto. - Qed. +(* Lemma mem_delta_apply_eq *) +(* d m0 *) +(* : *) +(* mem_delta_apply d m0 = mem_delta_apply_left (rev d) (Some m0). *) +(* Proof. *) +(* rewrite <- (rev_involutive d) at 1. unfold mem_delta_apply, mem_delta_apply_left. rewrite fold_left_rev_right. f_equal. *) +(* Qed. *) - 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. +(* (* Delta and injection relation *) *) +(* Definition mem_delta_kind_inj_wf (j: meminj): mem_delta_kind -> Prop := *) +(* fun data => *) +(* match data with *) +(* | 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_store_fo (j: meminj) (data: mem_delta_store): Prop := *) - (* let '(ch, b, ofs, v, cp) := data in *) - (* match j b with *) - (* | Some _ => Forall (fun mv => match mv with | Byte bt => True | _ => False end) (encode_val ch v) *) - (* | None => True *) - (* end. *) +(* Definition mem_delta_inj_wf (j: meminj): mem_delta -> Prop := *) +(* fun d => Forall (fun data => mem_delta_kind_inj_wf j data) d. *) - (* Definition mem_delta_inj_fo (j: meminj) (d: mem_delta): Prop := *) - (* Forall (fun data => *) - (* match data with *) - (* | mem_delta_kind_store d => mem_delta_inj_store_fo j d *) - (* | _ => True *) - (* end) d. *) - - Definition mem_delta_apply_inj (j: meminj) (d: mem_delta) (m0: mem) : option mem := - fold_right (fun data om => - match data with - | mem_delta_kind_store (ch, b, ofs, v, cp) => - match j b with - | Some (b', ofsd) => - mem_delta_apply_store om (ch, b', (ofs + ofsd)%Z, v, cp) - | None => om - end - | _ => om - end) (Some m0) d. - - Lemma mem_delta_apply_inj_cons - j d m0 m k - (MEM: mem_delta_apply_inj j d m0 = Some m) - : - mem_delta_apply_inj j (k :: d) m0 = - match k with - | mem_delta_kind_store (ch, b, ofs, v, cp) => - match j b with Some (b', ofsd) => mem_delta_apply_store (Some m) (ch, b', (ofs + ofsd)%Z, v, cp) | None => (Some m) end - | mem_delta_kind_bytes dd - | mem_delta_kind_alloc dd - | mem_delta_kind_free dd => Some m - end. - Proof. simpl. rewrite MEM. auto. Qed. - - Definition mem_delta_apply_inj_left (j: meminj) (d: mem_delta) (om0: option mem) : option mem := - fold_left (fun om data => - match data with - | mem_delta_kind_store (ch, b, ofs, v, cp) => - match j b with - | Some (b', ofsd) => - mem_delta_apply_store om (ch, b', (ofs + ofsd)%Z, v, cp) - | None => om - end - | _ => om - end) d (om0). - - Lemma mem_delta_apply_inj_left_cons - j d m0 k - : - mem_delta_apply_inj_left j (k :: d) m0 = - match k with - | mem_delta_kind_store (ch, b, ofs, v, cp) => - match j b with - | Some (b', ofsd) => - mem_delta_apply_inj_left j d (mem_delta_apply_store m0 (ch, b', (ofs + ofsd)%Z, v, cp)) - | None => mem_delta_apply_inj_left j d m0 - end - | mem_delta_kind_bytes dd - | mem_delta_kind_alloc dd - | mem_delta_kind_free dd => mem_delta_apply_inj_left j d m0 - end. - Proof. simpl. destruct k; auto. destruct d0 as [[[[a0 a1] a2] a3] a4]. destruct (j a1); auto. destruct p. auto. Qed. +(* Lemma mem_delta_inj_wf_rev *) +(* j d *) +(* : *) +(* mem_delta_inj_wf j d <-> mem_delta_inj_wf j (rev d). *) +(* Proof. *) +(* unfold mem_delta_inj_wf. split; intros. apply Forall_rev; auto. rewrite <- rev_involutive. apply Forall_rev. auto. *) +(* Qed. *) - Lemma mem_delta_apply_inj_left_app - j d0 d1 m0 - : - mem_delta_apply_inj_left j (d0 ++ d1) m0 = mem_delta_apply_inj_left j d1 (mem_delta_apply_inj_left j d0 m0). - Proof. - revert j d1 m0. induction d0; intros. - { simpl. auto. } - rewrite <- app_comm_cons. rewrite ! mem_delta_apply_inj_left_cons. destruct a; auto. - { destruct d as [[[[a0 a1] a2] a3] a4]. destruct (j a1); auto. destruct p; auto. } - Qed. +(* 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 mem_delta_inj_store_fo (j: meminj) (data: mem_delta_store): Prop := *) *) +(* (* let '(ch, b, ofs, v, cp) := data in *) *) +(* (* match j b with *) *) +(* (* | Some _ => Forall (fun mv => match mv with | Byte bt => True | _ => False end) (encode_val ch v) *) *) +(* (* | None => True *) *) +(* (* end. *) *) + +(* (* Definition mem_delta_inj_fo (j: meminj) (d: mem_delta): Prop := *) *) +(* (* Forall (fun data => *) *) +(* (* match data with *) *) +(* (* | mem_delta_kind_store d => mem_delta_inj_store_fo j d *) *) +(* (* | _ => True *) *) +(* (* end) d. *) *) + +(* Definition mem_delta_apply_inj (j: meminj) (d: mem_delta) (m0: mem) : option mem := *) +(* fold_right (fun data om => *) +(* match data with *) +(* | mem_delta_kind_store (ch, b, ofs, v, cp) => *) +(* match j b with *) +(* | Some (b', ofsd) => *) +(* mem_delta_apply_store om (ch, b', (ofs + ofsd)%Z, v, cp) *) +(* | None => om *) +(* end *) +(* | _ => om *) +(* end) (Some m0) d. *) + +(* Lemma mem_delta_apply_inj_cons *) +(* j d m0 m k *) +(* (MEM: mem_delta_apply_inj j d m0 = Some m) *) +(* : *) +(* mem_delta_apply_inj j (k :: d) m0 = *) +(* match k with *) +(* | mem_delta_kind_store (ch, b, ofs, v, cp) => *) +(* match j b with Some (b', ofsd) => mem_delta_apply_store (Some m) (ch, b', (ofs + ofsd)%Z, v, cp) | None => (Some m) end *) +(* | mem_delta_kind_bytes dd *) +(* | mem_delta_kind_alloc dd *) +(* | mem_delta_kind_free dd => Some m *) +(* end. *) +(* Proof. simpl. rewrite MEM. auto. Qed. *) + +(* Definition mem_delta_apply_inj_left (j: meminj) (d: mem_delta) (om0: option mem) : option mem := *) +(* fold_left (fun om data => *) +(* match data with *) +(* | mem_delta_kind_store (ch, b, ofs, v, cp) => *) +(* match j b with *) +(* | Some (b', ofsd) => *) +(* mem_delta_apply_store om (ch, b', (ofs + ofsd)%Z, v, cp) *) +(* | None => om *) +(* end *) +(* | _ => om *) +(* end) d (om0). *) + +(* Lemma mem_delta_apply_inj_left_cons *) +(* j d m0 k *) +(* : *) +(* mem_delta_apply_inj_left j (k :: d) m0 = *) +(* match k with *) +(* | mem_delta_kind_store (ch, b, ofs, v, cp) => *) +(* match j b with *) +(* | Some (b', ofsd) => *) +(* mem_delta_apply_inj_left j d (mem_delta_apply_store m0 (ch, b', (ofs + ofsd)%Z, v, cp)) *) +(* | None => mem_delta_apply_inj_left j d m0 *) +(* end *) +(* | mem_delta_kind_bytes dd *) +(* | mem_delta_kind_alloc dd *) +(* | mem_delta_kind_free dd => mem_delta_apply_inj_left j d m0 *) +(* end. *) +(* Proof. simpl. destruct k; auto. destruct d0 as [[[[a0 a1] a2] a3] a4]. destruct (j a1); auto. destruct p. auto. Qed. *) + +(* Lemma mem_delta_apply_inj_left_app *) +(* j d0 d1 m0 *) +(* : *) +(* mem_delta_apply_inj_left j (d0 ++ d1) m0 = mem_delta_apply_inj_left j d1 (mem_delta_apply_inj_left j d0 m0). *) +(* Proof. *) +(* revert j d1 m0. induction d0; intros. *) +(* { simpl. auto. } *) +(* rewrite <- app_comm_cons. rewrite ! mem_delta_apply_inj_left_cons. destruct a; auto. *) +(* { destruct d as [[[[a0 a1] a2] a3] a4]. destruct (j a1); auto. destruct p; auto. } *) +(* Qed. *) - Lemma mem_delta_apply_inj_eq - j d m0 - : - mem_delta_apply_inj j d m0 = mem_delta_apply_inj_left j (rev d) (Some m0). - Proof. - rewrite <- (rev_involutive d) at 1. unfold mem_delta_apply_inj, mem_delta_apply_inj_left. rewrite fold_left_rev_right. f_equal. - Qed. +(* Lemma mem_delta_apply_inj_eq *) +(* j d m0 *) +(* : *) +(* mem_delta_apply_inj j d m0 = mem_delta_apply_inj_left j (rev d) (Some m0). *) +(* Proof. *) +(* rewrite <- (rev_involutive d) at 1. unfold mem_delta_apply_inj, mem_delta_apply_inj_left. rewrite fold_left_rev_right. f_equal. *) +(* 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. +(* 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. *) - Lemma mem_delta_apply_preserves_full - (k j: meminj) m_i m0' - (INJ0: Mem.inject k m_i m0') - (INCR: inject_incr j k) - (d_pre d_post: mem_delta) - (DWFPRE: mem_delta_inj_wf j d_pre) - (DWFPOST: mem_delta_inj_wf j d_post) - m_m - (APPDPRE: mem_delta_apply_left d_pre (Some m_i) = Some m_m) - (WINJ: mem_weak_inject j m_m m0') - m_f - (APPDPOST: mem_delta_apply_left d_post (Some m_m) = Some m_f) - (MFO: meminj_first_order j m_f) - : - exists m1', (mem_delta_apply_inj j (d_pre ++ d_post) m0' = Some m1') /\ (Mem.inject j m_f m1'). - Proof. +(* Lemma mem_delta_apply_preserves_full *) +(* (k j: meminj) m_i m0' *) +(* (INJ0: Mem.inject k m_i m0') *) +(* (INCR: inject_incr j k) *) +(* (d_pre d_post: mem_delta) *) +(* (DWFPRE: mem_delta_inj_wf j d_pre) *) +(* (DWFPOST: mem_delta_inj_wf j d_post) *) +(* m_m *) +(* (APPDPRE: mem_delta_apply_left d_pre (Some m_i) = Some m_m) *) +(* (WINJ: mem_weak_inject j m_m m0') *) +(* m_f *) +(* (APPDPOST: mem_delta_apply_left d_post (Some m_m) = Some m_f) *) +(* (MFO: meminj_first_order j m_f) *) +(* : *) +(* exists m1', (mem_delta_apply_inj j (d_pre ++ d_post) m0' = Some m1') /\ (Mem.inject j m_f m1'). *) +(* Proof. *) - rewrite mem_delta_apply_eq in APPD. rewrite mem_delta_apply_inj_eq. rewrite mem_delta_inj_wf_rev in DWF. remember (rev d) as rd. clear d Heqrd. rename rd into d. - revert m0 m0' INJ0 DWF APPD. induction d; intros. - { unfold mem_delta_apply_inj_left. simpl. exists m0'. split; auto. unfold mem_delta_apply_left in APPD. simpl in APPD. inv APPD. auto. } - inv DWF. rename H1 into DWF1, H2 into DWF0. - rewrite mem_delta_apply_left_cons in APPD. rewrite mem_delta_apply_inj_left_cons. +(* rewrite mem_delta_apply_eq in APPD. rewrite mem_delta_apply_inj_eq. rewrite mem_delta_inj_wf_rev in DWF. remember (rev d) as rd. clear d Heqrd. rename rd into d. *) +(* revert m0 m0' INJ0 DWF APPD. induction d; intros. *) +(* { unfold mem_delta_apply_inj_left. simpl. exists m0'. split; auto. unfold mem_delta_apply_left in APPD. simpl in APPD. inv APPD. auto. } *) +(* inv DWF. rename H1 into DWF1, H2 into DWF0. *) +(* rewrite mem_delta_apply_left_cons in APPD. rewrite mem_delta_apply_inj_left_cons. *) - revert DWF DFO m1 APPD. induction d; simpl; intros. - { inv APPD. exists m0'. split; auto. } - inv DWF. rename H1 into DWF1, H2 into DWF0. inv DFO. rename H1 into DFO1, H2 into DFO0. - destruct (mem_delta_apply d m0) eqn:DAM. - 2:{ destruct a; - [rewrite mem_delta_apply_store_none in APPD; inv APPD - | rewrite mem_delta_apply_bytes_none in APPD; inv APPD - | rewrite mem_delta_apply_alloc_none in APPD; inv APPD - | rewrite mem_delta_apply_free_none in APPD; inv APPD]. - } - rename m into m_i. - specialize (IHd DWF0 DFO0 _ (eq_refl)). destruct IHd as (m_i' & DAM' & INJ_I). - rewrite DAM'. - destruct a. - - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. - destruct (j b) eqn:JB. - + destruct p as (b' & ofs'). eapply Mem.store_mapped_inject; eauto. - clear - DFO1. destruct v; auto. exfalso. simpl in *. destruct Archi.ptr64. - * destruct ch; simpl in *; try (inv DFO1; contradiction). - * destruct ch; simpl in *; try (inv DFO1; contradiction). - + exists m_i'; split; auto. eapply Mem.store_unmapped_inject; eauto. - - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. - exists m_i'; split; auto. eapply Mem.storebytes_unmapped_inject; eauto. - - destruct d0 as ((cp & lo) & hi). simpl in *. - exists m_i'; split; auto. destruct (Mem.alloc m_i cp lo hi) eqn:ALLOC. simpl in *. inv APPD. - eapply alloc_left_unmapped_inject_keep; eauto. - - destruct d0 as (((b & lo) & hi) & cp). simpl in *. - exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. - Qed. +(* revert DWF DFO m1 APPD. induction d; simpl; intros. *) +(* { inv APPD. exists m0'. split; auto. } *) +(* inv DWF. rename H1 into DWF1, H2 into DWF0. inv DFO. rename H1 into DFO1, H2 into DFO0. *) +(* destruct (mem_delta_apply d m0) eqn:DAM. *) +(* 2:{ destruct a; *) +(* [rewrite mem_delta_apply_store_none in APPD; inv APPD *) +(* | rewrite mem_delta_apply_bytes_none in APPD; inv APPD *) +(* | rewrite mem_delta_apply_alloc_none in APPD; inv APPD *) +(* | rewrite mem_delta_apply_free_none in APPD; inv APPD]. *) +(* } *) +(* rename m into m_i. *) +(* specialize (IHd DWF0 DFO0 _ (eq_refl)). destruct IHd as (m_i' & DAM' & INJ_I). *) +(* rewrite DAM'. *) +(* destruct a. *) +(* - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. *) +(* destruct (j b) eqn:JB. *) +(* + destruct p as (b' & ofs'). eapply Mem.store_mapped_inject; eauto. *) +(* clear - DFO1. destruct v; auto. exfalso. simpl in *. destruct Archi.ptr64. *) +(* * destruct ch; simpl in *; try (inv DFO1; contradiction). *) +(* * destruct ch; simpl in *; try (inv DFO1; contradiction). *) +(* + exists m_i'; split; auto. eapply Mem.store_unmapped_inject; eauto. *) +(* - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. *) +(* exists m_i'; split; auto. eapply Mem.storebytes_unmapped_inject; eauto. *) +(* - destruct d0 as ((cp & lo) & hi). simpl in *. *) +(* exists m_i'; split; auto. destruct (Mem.alloc m_i cp lo hi) eqn:ALLOC. simpl in *. inv APPD. *) +(* eapply alloc_left_unmapped_inject_keep; eauto. *) +(* - destruct d0 as (((b & lo) & hi) & cp). simpl in *. *) +(* exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. *) +(* Qed. *) - Lemma val_inject_incr_inv - f f' v v' - (INCR: inject_incr f f') - (INJ: Val.inject f' v v') - : - Val.inject f v v'. - Proof. - inv INJ; auto. eapply Val.inject_ptr; auto. -val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' +(* Lemma val_inject_incr_inv *) +(* f f' v v' *) +(* (INCR: inject_incr f f') *) +(* (INJ: Val.inject f' v v') *) +(* : *) +(* Val.inject f v v'. *) +(* Proof. *) +(* inv INJ; auto. eapply Val.inject_ptr; auto. *) +(* val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' *) - Lemma mem_inject_incr - f f' m m' - (INCR: inject_incr f f') - (INJ: Mem.inject f' m m') - : - Mem.inject f m m'. - Proof. - unfold Mem.inject in *. inv INJ. split; eauto. - 2:{ intros. specialize (mi_freeblocks _ H). unfold inject_incr in INCR. - destruct (f b) eqn:FB; auto. destruct p. specialize (INCR _ _ _ FB). - rewrite INCR in mi_freeblocks. inv mi_freeblocks. - } - 2:{ clear - INCR mi_no_overlap. unfold Mem.meminj_no_overlap in *. intros. - exploit mi_no_overlap; eauto. - } - clear - INCR mi_inj. inv mi_inj. split; eauto. intros. exploit mi_memval; eauto. intros. - eapply memval_inject_incr; eauto. - ` +(* Lemma mem_inject_incr *) +(* f f' m m' *) +(* (INCR: inject_incr f f') *) +(* (INJ: Mem.inject f' m m') *) +(* : *) +(* Mem.inject f m m'. *) +(* Proof. *) +(* unfold Mem.inject in *. inv INJ. split; eauto. *) +(* 2:{ intros. specialize (mi_freeblocks _ H). unfold inject_incr in INCR. *) +(* destruct (f b) eqn:FB; auto. destruct p. specialize (INCR _ _ _ FB). *) +(* rewrite INCR in mi_freeblocks. inv mi_freeblocks. *) +(* } *) +(* 2:{ clear - INCR mi_no_overlap. unfold Mem.meminj_no_overlap in *. intros. *) +(* exploit mi_no_overlap; eauto. *) +(* } *) +(* clear - INCR mi_inj. inv mi_inj. split; eauto. intros. exploit mi_memval; eauto. intros. *) +(* eapply memval_inject_incr; eauto. *) +(* ` *) -val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' -Unusedglobproof.regset_inject_incr: forall (f f' : meminj) (rs rs' : RTL.regset), Unusedglobproof.regset_inject f rs rs' -> inject_incr f f' -> Unusedglobproof.regset_inject f' rs rs' -memval_inject_incr: forall (f f' : meminj) (v1 v2 : memval), memval_inject f v1 v2 -> inject_incr f f' -> memval_inject f' v1 v2 -Stackingproof.agree_regs_inject_incr: forall (j : meminj) (ls : Linear.locset) (rs : Mach.regset) (j' : meminj), Stackingproof.agree_regs j ls rs -> inject_incr j j' -> Stackingproof.agree_regs j' ls rs -Cminorgenproof.match_temps_invariant: forall (f f' : meminj) (le : Csharpminor.temp_env) (te : Cminor.env), Cminorgenproof.match_temps f le te -> inject_incr f f' -> Cminorgenproof.match_temps f' le te -val_inject_list_incr: forall (f1 f2 : meminj) (vl vl' : list val), inject_incr f1 f2 -> Val.inject_list f1 vl vl' -> Val.inject_list f2 vl vl' - - Lemma mem_delta_apply_preserves_inj - (j: meminj) m0 m0' - (INJ0: Mem.inject j m0 m0') - (d: mem_delta) - (DWF: mem_delta_inj_wf j d) - (DFO: mem_delta_inj_fo j d) - m1 - (APPD: mem_delta_apply d m0 = Some m1) - : - exists m1', (mem_delta_apply_inj j d m0' = Some m1') /\ (Mem.inject j m1 m1'). - Proof. - revert DWF DFO m1 APPD. induction d; simpl; intros. - { inv APPD. exists m0'. split; auto. } - inv DWF. rename H1 into DWF1, H2 into DWF0. inv DFO. rename H1 into DFO1, H2 into DFO0. - destruct (mem_delta_apply d m0) eqn:DAM. - 2:{ destruct a; - [rewrite mem_delta_apply_store_none in APPD; inv APPD - | rewrite mem_delta_apply_bytes_none in APPD; inv APPD - | rewrite mem_delta_apply_alloc_none in APPD; inv APPD - | rewrite mem_delta_apply_free_none in APPD; inv APPD]. - } - rename m into m_i. - specialize (IHd DWF0 DFO0 _ (eq_refl)). destruct IHd as (m_i' & DAM' & INJ_I). - rewrite DAM'. - destruct a. - - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. - destruct (j b) eqn:JB. - + destruct p as (b' & ofs'). eapply Mem.store_mapped_inject; eauto. - clear - DFO1. destruct v; auto. exfalso. simpl in *. destruct Archi.ptr64. - * destruct ch; simpl in *; try (inv DFO1; contradiction). - * destruct ch; simpl in *; try (inv DFO1; contradiction). - + exists m_i'; split; auto. eapply Mem.store_unmapped_inject; eauto. - - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. - exists m_i'; split; auto. eapply Mem.storebytes_unmapped_inject; eauto. - - destruct d0 as ((cp & lo) & hi). simpl in *. - exists m_i'; split; auto. destruct (Mem.alloc m_i cp lo hi) eqn:ALLOC. simpl in *. inv APPD. - eapply alloc_left_unmapped_inject_keep; eauto. - - destruct d0 as (((b & lo) & hi) & cp). simpl in *. - exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. - Qed. +(* val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' *) +(* Unusedglobproof.regset_inject_incr: forall (f f' : meminj) (rs rs' : RTL.regset), Unusedglobproof.regset_inject f rs rs' -> inject_incr f f' -> Unusedglobproof.regset_inject f' rs rs' *) +(* memval_inject_incr: forall (f f' : meminj) (v1 v2 : memval), memval_inject f v1 v2 -> inject_incr f f' -> memval_inject f' v1 v2 *) +(* Stackingproof.agree_regs_inject_incr: forall (j : meminj) (ls : Linear.locset) (rs : Mach.regset) (j' : meminj), Stackingproof.agree_regs j ls rs -> inject_incr j j' -> Stackingproof.agree_regs j' ls rs *) +(* Cminorgenproof.match_temps_invariant: forall (f f' : meminj) (le : Csharpminor.temp_env) (te : Cminor.env), Cminorgenproof.match_temps f le te -> inject_incr f f' -> Cminorgenproof.match_temps f' le te *) +(* val_inject_list_incr: forall (f1 f2 : meminj) (vl vl' : list val), inject_incr f1 f2 -> Val.inject_list f1 vl vl' -> Val.inject_list f2 vl vl' *) + +(* Lemma mem_delta_apply_preserves_inj *) +(* (j: meminj) m0 m0' *) +(* (INJ0: Mem.inject j m0 m0') *) +(* (d: mem_delta) *) +(* (DWF: mem_delta_inj_wf j d) *) +(* (DFO: mem_delta_inj_fo j d) *) +(* m1 *) +(* (APPD: mem_delta_apply d m0 = Some m1) *) +(* : *) +(* exists m1', (mem_delta_apply_inj j d m0' = Some m1') /\ (Mem.inject j m1 m1'). *) +(* Proof. *) +(* revert DWF DFO m1 APPD. induction d; simpl; intros. *) +(* { inv APPD. exists m0'. split; auto. } *) +(* inv DWF. rename H1 into DWF1, H2 into DWF0. inv DFO. rename H1 into DFO1, H2 into DFO0. *) +(* destruct (mem_delta_apply d m0) eqn:DAM. *) +(* 2:{ destruct a; *) +(* [rewrite mem_delta_apply_store_none in APPD; inv APPD *) +(* | rewrite mem_delta_apply_bytes_none in APPD; inv APPD *) +(* | rewrite mem_delta_apply_alloc_none in APPD; inv APPD *) +(* | rewrite mem_delta_apply_free_none in APPD; inv APPD]. *) +(* } *) +(* rename m into m_i. *) +(* specialize (IHd DWF0 DFO0 _ (eq_refl)). destruct IHd as (m_i' & DAM' & INJ_I). *) +(* rewrite DAM'. *) +(* destruct a. *) +(* - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. *) +(* destruct (j b) eqn:JB. *) +(* + destruct p as (b' & ofs'). eapply Mem.store_mapped_inject; eauto. *) +(* clear - DFO1. destruct v; auto. exfalso. simpl in *. destruct Archi.ptr64. *) +(* * destruct ch; simpl in *; try (inv DFO1; contradiction). *) +(* * destruct ch; simpl in *; try (inv DFO1; contradiction). *) +(* + exists m_i'; split; auto. eapply Mem.store_unmapped_inject; eauto. *) +(* - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. *) +(* exists m_i'; split; auto. eapply Mem.storebytes_unmapped_inject; eauto. *) +(* - destruct d0 as ((cp & lo) & hi). simpl in *. *) +(* exists m_i'; split; auto. destruct (Mem.alloc m_i cp lo hi) eqn:ALLOC. simpl in *. inv APPD. *) +(* eapply alloc_left_unmapped_inject_keep; eauto. *) +(* - destruct d0 as (((b & lo) & hi) & cp). simpl in *. *) +(* exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. *) +(* Qed. *) - 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. - - Lemma mem_delta_apply_preserves_inj_incr - (j k: meminj) m0 m0' - (INCR: inject_incr j k) - (INJ0: Mem.inject k m0 m0') - (d: mem_delta) - (DWF: mem_delta_inj_wf j d) - (DFO: mem_delta_inj_fo j d) - m1 - (APPD: mem_delta_apply d m0 = Some m1) - (MIFO: meminj_first_order j m1) - : - exists m1', (mem_delta_apply_inj j d m0' = Some m1') /\ (Mem.inject j m1 m1'). - Proof. - revert DWF DFO m1 APPD MIFO. induction d; simpl; intros. - { inv APPD. exists m0'. split; auto. admit. (* MIFO *) } - inv DWF. rename H1 into DWF1, H2 into DWF0. inv DFO. rename H1 into DFO1, H2 into DFO0. - destruct (mem_delta_apply d m0) eqn:DAM. - 2:{ destruct a; - [rewrite mem_delta_apply_store_none in APPD; inv APPD - | rewrite mem_delta_apply_bytes_none in APPD; inv APPD - | rewrite mem_delta_apply_alloc_none in APPD; inv APPD - | rewrite mem_delta_apply_free_none in APPD; inv APPD]. - } - rename m into m_i. - specialize (IHd DWF0 DFO0 _ (eq_refl)). destruct IHd as (m_i' & DAM' & INJ_I). - { unfold meminj_first_order in *. intros. rename d into deltas. - specialize (MIFO _ ofs H). exploit MIFO; clear MIFO. - { destruct a; simpl in *. - - unfold mem_delta_apply_store in APPD. destruct d as [[[[ch0 b0] ofs0] v0] cp0]. - eapply Mem.perm_store_1; eauto. - - unfold mem_delta_apply_bytes in APPD. destruct d as [[[b0 ofs0] mvs0] cp0]. - eapply Mem.perm_storebytes_1; eauto. - - unfold mem_delta_apply_alloc in APPD. destruct d as [[cp0 lo0] hi0]. - destruct (Mem.alloc m_i cp0 lo0 hi0) eqn:CASES. inv APPD. - eapply Mem.perm_alloc_1; eauto. - - unfold mem_delta_apply_free in APPD. destruct d as [[[b0 lo0] hi0] cp0]. - eapply Mem.perm_free_1; eauto. left. intros EQ. subst. rewrite DWF1 in H. congruence. - } - intros MIFO. clear H0. - { destruct a; simpl in *. - - unfold mem_delta_apply_store in APPD. destruct d as [[[[ch0 b0] ofs0] v0] cp0]. - destruct (Pos.eqb_spec b b0). - + subst b0. unfold mem_delta_inj_store_fo in DFO1. - destruct (j b) eqn:JB. 2: congruence. clear H. destruct p. - unfold loc_first_order in *. clear MIFO APPD. +(* 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. *) + +(* Lemma mem_delta_apply_preserves_inj_incr *) +(* (j k: meminj) m0 m0' *) +(* (INCR: inject_incr j k) *) +(* (INJ0: Mem.inject k m0 m0') *) +(* (d: mem_delta) *) +(* (DWF: mem_delta_inj_wf j d) *) +(* (DFO: mem_delta_inj_fo j d) *) +(* m1 *) +(* (APPD: mem_delta_apply d m0 = Some m1) *) +(* (MIFO: meminj_first_order j m1) *) +(* : *) +(* exists m1', (mem_delta_apply_inj j d m0' = Some m1') /\ (Mem.inject j m1 m1'). *) +(* Proof. *) +(* revert DWF DFO m1 APPD MIFO. induction d; simpl; intros. *) +(* { inv APPD. exists m0'. split; auto. admit. (* MIFO *) } *) +(* inv DWF. rename H1 into DWF1, H2 into DWF0. inv DFO. rename H1 into DFO1, H2 into DFO0. *) +(* destruct (mem_delta_apply d m0) eqn:DAM. *) +(* 2:{ destruct a; *) +(* [rewrite mem_delta_apply_store_none in APPD; inv APPD *) +(* | rewrite mem_delta_apply_bytes_none in APPD; inv APPD *) +(* | rewrite mem_delta_apply_alloc_none in APPD; inv APPD *) +(* | rewrite mem_delta_apply_free_none in APPD; inv APPD]. *) +(* } *) +(* rename m into m_i. *) +(* specialize (IHd DWF0 DFO0 _ (eq_refl)). destruct IHd as (m_i' & DAM' & INJ_I). *) +(* { unfold meminj_first_order in *. intros. rename d into deltas. *) +(* specialize (MIFO _ ofs H). exploit MIFO; clear MIFO. *) +(* { destruct a; simpl in *. *) +(* - unfold mem_delta_apply_store in APPD. destruct d as [[[[ch0 b0] ofs0] v0] cp0]. *) +(* eapply Mem.perm_store_1; eauto. *) +(* - unfold mem_delta_apply_bytes in APPD. destruct d as [[[b0 ofs0] mvs0] cp0]. *) +(* eapply Mem.perm_storebytes_1; eauto. *) +(* - unfold mem_delta_apply_alloc in APPD. destruct d as [[cp0 lo0] hi0]. *) +(* destruct (Mem.alloc m_i cp0 lo0 hi0) eqn:CASES. inv APPD. *) +(* eapply Mem.perm_alloc_1; eauto. *) +(* - unfold mem_delta_apply_free in APPD. destruct d as [[[b0 lo0] hi0] cp0]. *) +(* eapply Mem.perm_free_1; eauto. left. intros EQ. subst. rewrite DWF1 in H. congruence. *) +(* } *) +(* intros MIFO. clear H0. *) +(* { destruct a; simpl in *. *) +(* - unfold mem_delta_apply_store in APPD. destruct d as [[[[ch0 b0] ofs0] v0] cp0]. *) +(* destruct (Pos.eqb_spec b b0). *) +(* + subst b0. unfold mem_delta_inj_store_fo in DFO1. *) +(* destruct (j b) eqn:JB. 2: congruence. clear H. destruct p. *) +(* unfold loc_first_order in *. clear MIFO APPD. *) -Mem.store_mem_contents: - forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) - (cp : compartment) (m2 : mem), - Mem.store chunk m1 b ofs v cp = Some m2 -> - Mem.mem_contents m2 = - PMap.set b (Mem.setN (encode_val chunk v) ofs (Mem.mem_contents m1) !! b) (Mem.mem_contents m1) +(* Mem.store_mem_contents: *) +(* forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) *) +(* (cp : compartment) (m2 : mem), *) +(* Mem.store chunk m1 b ofs v cp = Some m2 -> *) +(* Mem.mem_contents m2 = *) +(* PMap.set b (Mem.setN (encode_val chunk v) ofs (Mem.mem_contents m1) !! b) (Mem.mem_contents m1) *) - eapply Mem.perm_store_1; eauto. - - unfold mem_delta_apply_bytes in APPD. destruct d as [[[b0 ofs0] mvs0] cp0]. - eapply Mem.perm_storebytes_1; eauto. - - unfold mem_delta_apply_alloc in APPD. destruct d as [[cp0 lo0] hi0]. - destruct (Mem.alloc m_i cp0 lo0 hi0) eqn:CASES. inv APPD. - eapply Mem.perm_alloc_1; eauto. - - unfold mem_delta_apply_free in APPD. destruct d as [[[b0 lo0] hi0] cp0]. - eapply Mem.perm_free_1; eauto. left. intros EQ. subst. rewrite DWF1 in H. congruence. - } +(* eapply Mem.perm_store_1; eauto. *) +(* - unfold mem_delta_apply_bytes in APPD. destruct d as [[[b0 ofs0] mvs0] cp0]. *) +(* eapply Mem.perm_storebytes_1; eauto. *) +(* - unfold mem_delta_apply_alloc in APPD. destruct d as [[cp0 lo0] hi0]. *) +(* destruct (Mem.alloc m_i cp0 lo0 hi0) eqn:CASES. inv APPD. *) +(* eapply Mem.perm_alloc_1; eauto. *) +(* - unfold mem_delta_apply_free in APPD. destruct d as [[[b0 lo0] hi0] cp0]. *) +(* eapply Mem.perm_free_1; eauto. left. intros EQ. subst. rewrite DWF1 in H. congruence. *) +(* } *) - rewrite DAM'. - destruct a. - - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. - destruct (j b) eqn:JB. - + destruct p as (b' & ofs'). eapply Mem.store_mapped_inject; eauto. - clear - DFO1. destruct v; auto. exfalso. simpl in *. destruct Archi.ptr64. - * destruct ch; simpl in *; try (inv DFO1; contradiction). - * destruct ch; simpl in *; try (inv DFO1; contradiction). - + exists m_i'; split; auto. eapply Mem.store_unmapped_inject; eauto. - - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. - exists m_i'; split; auto. eapply Mem.storebytes_unmapped_inject; eauto. - - destruct d0 as ((cp & lo) & hi). simpl in *. - exists m_i'; split; auto. destruct (Mem.alloc m_i cp lo hi) eqn:ALLOC. simpl in *. inv APPD. - eapply alloc_left_unmapped_inject_keep; eauto. - - destruct d0 as (((b & lo) & hi) & cp). simpl in *. - exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. - Qed. +(* rewrite DAM'. *) +(* destruct a. *) +(* - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. *) +(* destruct (j b) eqn:JB. *) +(* + destruct p as (b' & ofs'). eapply Mem.store_mapped_inject; eauto. *) +(* clear - DFO1. destruct v; auto. exfalso. simpl in *. destruct Archi.ptr64. *) +(* * destruct ch; simpl in *; try (inv DFO1; contradiction). *) +(* * destruct ch; simpl in *; try (inv DFO1; contradiction). *) +(* + exists m_i'; split; auto. eapply Mem.store_unmapped_inject; eauto. *) +(* - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. *) +(* exists m_i'; split; auto. eapply Mem.storebytes_unmapped_inject; eauto. *) +(* - destruct d0 as ((cp & lo) & hi). simpl in *. *) +(* exists m_i'; split; auto. destruct (Mem.alloc m_i cp lo hi) eqn:ALLOC. simpl in *. inv APPD. *) +(* eapply alloc_left_unmapped_inject_keep; eauto. *) +(* - destruct d0 as (((b & lo) & hi) & cp). simpl in *. *) +(* exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. *) +(* Qed. *) - (* 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. - - - (DFO: mem_delta_inj_fo j d) - visible_fo_if_unknown ef ge m vargs -> - | None => visible_fo ge m (sig_args sg) args -visible_fo = -fun (ge : Senv.t) (m : mem) (tys : list typ) (args : list val) => -public_first_order ge m /\ vals_public ge tys args - : Senv.t -> mem -> list typ -> list val -> Prop -public_first_order = -fun (ge : Senv.t) (m : mem) => -forall (id : ident) (b : block) (ofs : Z), -Senv.public_symbol ge id = true -> -Senv.find_symbol ge id = Some b -> Mem.perm m b ofs Cur Readable -> loc_first_order m b ofs - : Senv.t -> mem -> Prop - - (* TODO: this is false --- pointers can mess around *) -(* Lemma val_inject_incr_inv *) -(* f f' v v' *) +(* (* 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. *) + + +(* (DFO: mem_delta_inj_fo j d) *) +(* visible_fo_if_unknown ef ge m vargs -> *) +(* | None => visible_fo ge m (sig_args sg) args *) +(* visible_fo = *) +(* fun (ge : Senv.t) (m : mem) (tys : list typ) (args : list val) => *) +(* public_first_order ge m /\ vals_public ge tys args *) +(* : Senv.t -> mem -> list typ -> list val -> Prop *) +(* public_first_order = *) +(* fun (ge : Senv.t) (m : mem) => *) +(* forall (id : ident) (b : block) (ofs : Z), *) +(* Senv.public_symbol ge id = true -> *) +(* Senv.find_symbol ge id = Some b -> Mem.perm m b ofs Cur Readable -> loc_first_order m b ofs *) +(* : Senv.t -> mem -> Prop *) + +(* (* TODO: this is false --- pointers can mess around *) *) +(* (* Lemma val_inject_incr_inv *) *) +(* (* f f' v v' *) *) +(* (* (INCR: inject_incr f f') *) *) +(* (* (INJ: Val.inject f' v v') *) *) +(* (* : *) *) +(* (* Val.inject f v v'. *) *) +(* (* Proof. *) *) +(* (* inv INJ; auto. eapply Val.inject_ptr; auto. *) *) +(* (* val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' *) *) + +(* Lemma mem_inject_incr *) +(* f f' m m' *) (* (INCR: inject_incr f f') *) -(* (INJ: Val.inject f' v v') *) +(* (INJ: Mem.inject f' m m') *) (* : *) -(* Val.inject f v v'. *) +(* Mem.inject f m m'. *) (* Proof. *) -(* inv INJ; auto. eapply Val.inject_ptr; auto. *) -(* val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' *) - - Lemma mem_inject_incr - f f' m m' - (INCR: inject_incr f f') - (INJ: Mem.inject f' m m') - : - Mem.inject f m m'. - Proof. - unfold Mem.inject in *. inv INJ. split; eauto. - 2:{ intros. specialize (mi_freeblocks _ H). unfold inject_incr in INCR. - destruct (f b) eqn:FB; auto. destruct p. specialize (INCR _ _ _ FB). - rewrite INCR in mi_freeblocks. inv mi_freeblocks. - } - 2:{ clear - INCR mi_no_overlap. unfold Mem.meminj_no_overlap in *. intros. - exploit mi_no_overlap; eauto. - } - clear - INCR mi_inj. inv mi_inj. split; eauto. intros. exploit mi_memval; eauto. intros. - eapply memval_inject_incr; eauto. - ` +(* unfold Mem.inject in *. inv INJ. split; eauto. *) +(* 2:{ intros. specialize (mi_freeblocks _ H). unfold inject_incr in INCR. *) +(* destruct (f b) eqn:FB; auto. destruct p. specialize (INCR _ _ _ FB). *) +(* rewrite INCR in mi_freeblocks. inv mi_freeblocks. *) +(* } *) +(* 2:{ clear - INCR mi_no_overlap. unfold Mem.meminj_no_overlap in *. intros. *) +(* exploit mi_no_overlap; eauto. *) +(* } *) +(* clear - INCR mi_inj. inv mi_inj. split; eauto. intros. exploit mi_memval; eauto. intros. *) +(* eapply memval_inject_incr; eauto. *) +(* ` *) -val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' -Unusedglobproof.regset_inject_incr: forall (f f' : meminj) (rs rs' : RTL.regset), Unusedglobproof.regset_inject f rs rs' -> inject_incr f f' -> Unusedglobproof.regset_inject f' rs rs' -memval_inject_incr: forall (f f' : meminj) (v1 v2 : memval), memval_inject f v1 v2 -> inject_incr f f' -> memval_inject f' v1 v2 -Stackingproof.agree_regs_inject_incr: forall (j : meminj) (ls : Linear.locset) (rs : Mach.regset) (j' : meminj), Stackingproof.agree_regs j ls rs -> inject_incr j j' -> Stackingproof.agree_regs j' ls rs -Cminorgenproof.match_temps_invariant: forall (f f' : meminj) (le : Csharpminor.temp_env) (te : Cminor.env), Cminorgenproof.match_temps f le te -> inject_incr f f' -> Cminorgenproof.match_temps f' le te -val_inject_list_incr: forall (f1 f2 : meminj) (vl vl' : list val), inject_incr f1 f2 -> Val.inject_list f1 vl vl' -> Val.inject_list f2 vl vl' +(* val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' *) +(* Unusedglobproof.regset_inject_incr: forall (f f' : meminj) (rs rs' : RTL.regset), Unusedglobproof.regset_inject f rs rs' -> inject_incr f f' -> Unusedglobproof.regset_inject f' rs rs' *) +(* memval_inject_incr: forall (f f' : meminj) (v1 v2 : memval), memval_inject f v1 v2 -> inject_incr f f' -> memval_inject f' v1 v2 *) +(* Stackingproof.agree_regs_inject_incr: forall (j : meminj) (ls : Linear.locset) (rs : Mach.regset) (j' : meminj), Stackingproof.agree_regs j ls rs -> inject_incr j j' -> Stackingproof.agree_regs j' ls rs *) +(* Cminorgenproof.match_temps_invariant: forall (f f' : meminj) (le : Csharpminor.temp_env) (te : Cminor.env), Cminorgenproof.match_temps f le te -> inject_incr f f' -> Cminorgenproof.match_temps f' le te *) +(* val_inject_list_incr: forall (f1 f2 : meminj) (vl vl' : list val), inject_incr f1 f2 -> Val.inject_list f1 vl vl' -> Val.inject_list f2 vl vl' *) -End MEMDELTA. +(* End MEMDELTA. *) Section BUNDLE. diff --git a/security/MemoryDelta.v b/security/MemoryDelta.v new file mode 100644 index 0000000000..fe636cb71f --- /dev/null +++ b/security/MemoryDelta.v @@ -0,0 +1,818 @@ +Require Import String. +Require Import Coqlib Maps Errors Integers Values Memory Globalenvs. +Require Import AST Linking Smallstep Events Behaviors. +Require Import MemoryWeak. + +Section MEMDELTA. + + (** Memory delta data and apply *) + + (* Data to get injection by invoking correct Mem.store: inj + (apply delta) = inj *) + 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_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) + . + + (* old to new *) + Definition mem_delta := list mem_delta_kind. + + 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 (d: mem_delta) (m0: mem) : option mem := *) + (* fold_right (fun data om => *) + (* match data with *) + (* | 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 *) + (* ) (Some m0) d. *) + + (* Lemma mem_delta_apply_cons *) + (* d m0 m k *) + (* (MEM: mem_delta_apply d m0 = Some m) *) + (* : *) + (* mem_delta_apply (k :: d) m0 = *) + (* match k with *) + (* | mem_delta_kind_store dd => mem_delta_apply_store (Some m) dd *) + (* | mem_delta_kind_bytes dd => mem_delta_apply_bytes (Some m) dd *) + (* | mem_delta_kind_alloc dd => mem_delta_apply_alloc (Some m) dd *) + (* | mem_delta_kind_free dd => mem_delta_apply_free (Some m) dd *) + (* end. *) + (* Proof. simpl. rewrite MEM. auto. Qed. *) + + Definition mem_delta_apply (d: mem_delta) (om0: option mem) : option mem := + fold_left (fun om data => + match data with + | 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 + ) d om0. + + Lemma mem_delta_apply_cons + d m0 k + : + mem_delta_apply (k :: d) m0 = + match k with + | 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_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_eq *) + (* d m0 *) + (* : *) + (* mem_delta_apply d m0 = mem_delta_apply_left (rev d) (Some m0). *) + (* Proof. *) + (* rewrite <- (rev_involutive d) at 1. unfold mem_delta_apply, mem_delta_apply_left. rewrite fold_left_rev_right. f_equal. *) + (* Qed. *) + + (* Definition mem_delta_apply_inj (j: meminj) (d: mem_delta) (m0: mem) : option mem := *) + (* fold_right (fun data om => *) + (* match data with *) + (* | mem_delta_kind_store (ch, b, ofs, v, cp) => *) + (* match j b with *) + (* | Some (b', ofsd) => *) + (* mem_delta_apply_store om (ch, b', (ofs + ofsd)%Z, v, cp) *) + (* | None => om *) + (* end *) + (* | _ => om *) + (* end) (Some m0) d. *) + + (* Lemma mem_delta_apply_inj_cons *) + (* j d m0 m k *) + (* (MEM: mem_delta_apply_inj j d m0 = Some m) *) + (* : *) + (* mem_delta_apply_inj j (k :: d) m0 = *) + (* match k with *) + (* | mem_delta_kind_store (ch, b, ofs, v, cp) => *) + (* match j b with Some (b', ofsd) => mem_delta_apply_store (Some m) (ch, b', (ofs + ofsd)%Z, v, cp) | None => (Some m) end *) + (* | mem_delta_kind_bytes dd *) + (* | mem_delta_kind_alloc dd *) + (* | mem_delta_kind_free dd => Some m *) + (* end. *) + (* Proof. simpl. rewrite MEM. auto. Qed. *) + + Definition mem_delta_apply_inj (j: meminj) (d: mem_delta) (om0: option mem) : option mem := + fold_left (fun om data => + match data with + | mem_delta_kind_store (ch, b, ofs, v, cp) => + match j b with + | Some (b', ofsd) => + mem_delta_apply_store om (ch, b', (ofs + ofsd)%Z, v, cp) + | None => om + end + | _ => om + end) d (om0). + + Lemma mem_delta_apply_inj_cons + j d m0 k + : + mem_delta_apply_inj j (k :: d) m0 = + match k with + | mem_delta_kind_store (ch, b, ofs, v, cp) => + match j b with + | Some (b', ofsd) => + mem_delta_apply_inj j d (mem_delta_apply_store m0 (ch, b', (ofs + ofsd)%Z, v, cp)) + | None => mem_delta_apply_inj j d m0 + end + | mem_delta_kind_bytes dd + | mem_delta_kind_alloc dd + | mem_delta_kind_free dd => mem_delta_apply_inj j d m0 + end. + Proof. simpl. destruct k; auto. destruct d0 as [[[[a0 a1] a2] a3] a4]. destruct (j a1); auto. destruct p. auto. Qed. + + Lemma mem_delta_apply_inj_app + j d0 d1 m0 + : + mem_delta_apply_inj j (d0 ++ d1) m0 = mem_delta_apply_inj j d1 (mem_delta_apply_inj j d0 m0). + Proof. + revert j d1 m0. induction d0; intros. + { simpl. auto. } + rewrite <- app_comm_cons. rewrite ! mem_delta_apply_inj_cons. destruct a; auto. + { destruct d as [[[[a0 a1] a2] a3] a4]. destruct (j a1); auto. destruct p; auto. } + Qed. + + Lemma mem_delta_apply_inj_none + j d + : + mem_delta_apply_inj j d None = None. + Proof. + induction d; auto. rewrite mem_delta_apply_inj_cons. + destruct a. destruct d0 as [[[[a0 a1] a2] a3] a4]. destruct (j a1). destruct p. rewrite mem_delta_apply_store_none. all: rewrite IHd; auto. + Qed. + + (* Lemma mem_delta_apply_inj_eq *) + (* j d m0 *) + (* : *) + (* mem_delta_apply_inj j d m0 = mem_delta_apply_inj_left j (rev d) (Some m0). *) + (* Proof. *) + (* rewrite <- (rev_involutive d) at 1. unfold mem_delta_apply_inj, mem_delta_apply_inj_left. rewrite fold_left_rev_right. f_equal. *) + (* Qed. *) + + + (** Delta and injection relations *) + + Definition mem_delta_kind_inj_wf (j: meminj): mem_delta_kind -> Prop := + fun data => + match data with + | 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 (j: meminj): mem_delta -> Prop := + fun d => Forall (fun data => mem_delta_kind_inj_wf j data) d. + + Lemma mem_delta_inj_wf_rev + j d + : + mem_delta_inj_wf j d <-> mem_delta_inj_wf j (rev d). + Proof. + unfold mem_delta_inj_wf. split; intros. apply Forall_rev; auto. rewrite <- rev_involutive. apply Forall_rev. auto. + Qed. + + 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 mem_delta_inj_store_fo (j: meminj) (data: mem_delta_store): Prop := *) + (* let '(ch, b, ofs, v, cp) := data in *) + (* match j b with *) + (* | Some _ => Forall (fun mv => match mv with | Byte bt => True | _ => False end) (encode_val ch v) *) + (* | None => True *) + (* end. *) + + (* Definition mem_delta_inj_fo (j: meminj) (d: mem_delta): Prop := *) + (* Forall (fun data => *) + (* match data with *) + (* | mem_delta_kind_store d => mem_delta_inj_store_fo j d *) + (* | _ => True *) + (* end) d. *) + + + (** Delta and location relations *) + + 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). simpl in *. + 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_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 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. + + + + + + + + + Mem.unchanged_on_contents: + forall (P : block -> Z -> Prop) (m_before m_after : mem), + Mem.unchanged_on P m_before m_after -> + forall (b : block) (ofs : Z), P b ofs -> Mem.perm m_before b ofs Cur Readable -> ZMap.get ofs (Mem.mem_contents m_after) !! b = ZMap.get ofs (Mem.mem_contents m_before) !! b + + mi_memval : 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) }. + + +Mem.load_store_overlap: + forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) (m2 : mem) (chunk' : memory_chunk) (ofs' : Z) (cp' : option compartment) (v' : val), + Mem.store chunk m1 b ofs v cp = Some m2 -> + Mem.load chunk' m2 b ofs' cp' = Some v' -> + ofs' + size_chunk chunk' > ofs -> + ofs + size_chunk chunk > ofs' -> + exists (mv1 : memval) (mvl : list memval) (mv1' : memval) (mvl' : list memval), + shape_encoding chunk v (mv1 :: mvl) /\ shape_decoding chunk' (mv1' :: mvl') v' /\ (ofs' = ofs /\ mv1' = mv1 \/ ofs' > ofs /\ In mv1' mvl \/ ofs' < ofs /\ In mv1 mvl') + + + + (* Properties *) + 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. + + Lemma mem_delta_apply_preserves_full + (k j: meminj) m_i m0' + (INJ0: Mem.inject k m_i m0') + (INCR: inject_incr j k) + (d_pre d_post: mem_delta) + (DWFPRE: mem_delta_inj_wf j d_pre) + (DWFPOST: mem_delta_inj_wf j d_post) + m_m + (APPDPRE: mem_delta_apply_left d_pre (Some m_i) = Some m_m) + (WINJ: mem_weak_inject j m_m m0') + m_f + (APPDPOST: mem_delta_apply_left d_post (Some m_m) = Some m_f) + (MFO: meminj_first_order j m_f) + : + exists m1', (mem_delta_apply_inj j (d_pre ++ d_post) m0' = Some m1') /\ (Mem.inject j m_f m1'). + Proof. + + + + rewrite mem_delta_apply_eq in APPD. rewrite mem_delta_apply_inj_eq. rewrite mem_delta_inj_wf_rev in DWF. remember (rev d) as rd. clear d Heqrd. rename rd into d. + revert m0 m0' INJ0 DWF APPD. induction d; intros. + { unfold mem_delta_apply_inj_left. simpl. exists m0'. split; auto. unfold mem_delta_apply_left in APPD. simpl in APPD. inv APPD. auto. } + inv DWF. rename H1 into DWF1, H2 into DWF0. + rewrite mem_delta_apply_left_cons in APPD. rewrite mem_delta_apply_inj_left_cons. + + + + + + revert DWF DFO m1 APPD. induction d; simpl; intros. + { inv APPD. exists m0'. split; auto. } + inv DWF. rename H1 into DWF1, H2 into DWF0. inv DFO. rename H1 into DFO1, H2 into DFO0. + destruct (mem_delta_apply d m0) eqn:DAM. + 2:{ destruct a; + [rewrite mem_delta_apply_store_none in APPD; inv APPD + | rewrite mem_delta_apply_bytes_none in APPD; inv APPD + | rewrite mem_delta_apply_alloc_none in APPD; inv APPD + | rewrite mem_delta_apply_free_none in APPD; inv APPD]. + } + rename m into m_i. + specialize (IHd DWF0 DFO0 _ (eq_refl)). destruct IHd as (m_i' & DAM' & INJ_I). + rewrite DAM'. + destruct a. + - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. + destruct (j b) eqn:JB. + + destruct p as (b' & ofs'). eapply Mem.store_mapped_inject; eauto. + clear - DFO1. destruct v; auto. exfalso. simpl in *. destruct Archi.ptr64. + * destruct ch; simpl in *; try (inv DFO1; contradiction). + * destruct ch; simpl in *; try (inv DFO1; contradiction). + + exists m_i'; split; auto. eapply Mem.store_unmapped_inject; eauto. + - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. + exists m_i'; split; auto. eapply Mem.storebytes_unmapped_inject; eauto. + - destruct d0 as ((cp & lo) & hi). simpl in *. + exists m_i'; split; auto. destruct (Mem.alloc m_i cp lo hi) eqn:ALLOC. simpl in *. inv APPD. + eapply alloc_left_unmapped_inject_keep; eauto. + - destruct d0 as (((b & lo) & hi) & cp). simpl in *. + exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. + Qed. + + Lemma val_inject_incr_inv + f f' v v' + (INCR: inject_incr f f') + (INJ: Val.inject f' v v') + : + Val.inject f v v'. + Proof. + inv INJ; auto. eapply Val.inject_ptr; auto. +val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' + + Lemma mem_inject_incr + f f' m m' + (INCR: inject_incr f f') + (INJ: Mem.inject f' m m') + : + Mem.inject f m m'. + Proof. + unfold Mem.inject in *. inv INJ. split; eauto. + 2:{ intros. specialize (mi_freeblocks _ H). unfold inject_incr in INCR. + destruct (f b) eqn:FB; auto. destruct p. specialize (INCR _ _ _ FB). + rewrite INCR in mi_freeblocks. inv mi_freeblocks. + } + 2:{ clear - INCR mi_no_overlap. unfold Mem.meminj_no_overlap in *. intros. + exploit mi_no_overlap; eauto. + } + clear - INCR mi_inj. inv mi_inj. split; eauto. intros. exploit mi_memval; eauto. intros. + eapply memval_inject_incr; eauto. + ` + +val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' +Unusedglobproof.regset_inject_incr: forall (f f' : meminj) (rs rs' : RTL.regset), Unusedglobproof.regset_inject f rs rs' -> inject_incr f f' -> Unusedglobproof.regset_inject f' rs rs' +memval_inject_incr: forall (f f' : meminj) (v1 v2 : memval), memval_inject f v1 v2 -> inject_incr f f' -> memval_inject f' v1 v2 +Stackingproof.agree_regs_inject_incr: forall (j : meminj) (ls : Linear.locset) (rs : Mach.regset) (j' : meminj), Stackingproof.agree_regs j ls rs -> inject_incr j j' -> Stackingproof.agree_regs j' ls rs +Cminorgenproof.match_temps_invariant: forall (f f' : meminj) (le : Csharpminor.temp_env) (te : Cminor.env), Cminorgenproof.match_temps f le te -> inject_incr f f' -> Cminorgenproof.match_temps f' le te +val_inject_list_incr: forall (f1 f2 : meminj) (vl vl' : list val), inject_incr f1 f2 -> Val.inject_list f1 vl vl' -> Val.inject_list f2 vl vl' + + Lemma mem_delta_apply_preserves_inj + (j: meminj) m0 m0' + (INJ0: Mem.inject j m0 m0') + (d: mem_delta) + (DWF: mem_delta_inj_wf j d) + (DFO: mem_delta_inj_fo j d) + m1 + (APPD: mem_delta_apply d m0 = Some m1) + : + exists m1', (mem_delta_apply_inj j d m0' = Some m1') /\ (Mem.inject j m1 m1'). + Proof. + revert DWF DFO m1 APPD. induction d; simpl; intros. + { inv APPD. exists m0'. split; auto. } + inv DWF. rename H1 into DWF1, H2 into DWF0. inv DFO. rename H1 into DFO1, H2 into DFO0. + destruct (mem_delta_apply d m0) eqn:DAM. + 2:{ destruct a; + [rewrite mem_delta_apply_store_none in APPD; inv APPD + | rewrite mem_delta_apply_bytes_none in APPD; inv APPD + | rewrite mem_delta_apply_alloc_none in APPD; inv APPD + | rewrite mem_delta_apply_free_none in APPD; inv APPD]. + } + rename m into m_i. + specialize (IHd DWF0 DFO0 _ (eq_refl)). destruct IHd as (m_i' & DAM' & INJ_I). + rewrite DAM'. + destruct a. + - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. + destruct (j b) eqn:JB. + + destruct p as (b' & ofs'). eapply Mem.store_mapped_inject; eauto. + clear - DFO1. destruct v; auto. exfalso. simpl in *. destruct Archi.ptr64. + * destruct ch; simpl in *; try (inv DFO1; contradiction). + * destruct ch; simpl in *; try (inv DFO1; contradiction). + + exists m_i'; split; auto. eapply Mem.store_unmapped_inject; eauto. + - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. + exists m_i'; split; auto. eapply Mem.storebytes_unmapped_inject; eauto. + - destruct d0 as ((cp & lo) & hi). simpl in *. + exists m_i'; split; auto. destruct (Mem.alloc m_i cp lo hi) eqn:ALLOC. simpl in *. inv APPD. + eapply alloc_left_unmapped_inject_keep; eauto. + - destruct d0 as (((b & lo) & hi) & cp). simpl in *. + exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. + Qed. + + 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. + + Lemma mem_delta_apply_preserves_inj_incr + (j k: meminj) m0 m0' + (INCR: inject_incr j k) + (INJ0: Mem.inject k m0 m0') + (d: mem_delta) + (DWF: mem_delta_inj_wf j d) + (DFO: mem_delta_inj_fo j d) + m1 + (APPD: mem_delta_apply d m0 = Some m1) + (MIFO: meminj_first_order j m1) + : + exists m1', (mem_delta_apply_inj j d m0' = Some m1') /\ (Mem.inject j m1 m1'). + Proof. + revert DWF DFO m1 APPD MIFO. induction d; simpl; intros. + { inv APPD. exists m0'. split; auto. admit. (* MIFO *) } + inv DWF. rename H1 into DWF1, H2 into DWF0. inv DFO. rename H1 into DFO1, H2 into DFO0. + destruct (mem_delta_apply d m0) eqn:DAM. + 2:{ destruct a; + [rewrite mem_delta_apply_store_none in APPD; inv APPD + | rewrite mem_delta_apply_bytes_none in APPD; inv APPD + | rewrite mem_delta_apply_alloc_none in APPD; inv APPD + | rewrite mem_delta_apply_free_none in APPD; inv APPD]. + } + rename m into m_i. + specialize (IHd DWF0 DFO0 _ (eq_refl)). destruct IHd as (m_i' & DAM' & INJ_I). + { unfold meminj_first_order in *. intros. rename d into deltas. + specialize (MIFO _ ofs H). exploit MIFO; clear MIFO. + { destruct a; simpl in *. + - unfold mem_delta_apply_store in APPD. destruct d as [[[[ch0 b0] ofs0] v0] cp0]. + eapply Mem.perm_store_1; eauto. + - unfold mem_delta_apply_bytes in APPD. destruct d as [[[b0 ofs0] mvs0] cp0]. + eapply Mem.perm_storebytes_1; eauto. + - unfold mem_delta_apply_alloc in APPD. destruct d as [[cp0 lo0] hi0]. + destruct (Mem.alloc m_i cp0 lo0 hi0) eqn:CASES. inv APPD. + eapply Mem.perm_alloc_1; eauto. + - unfold mem_delta_apply_free in APPD. destruct d as [[[b0 lo0] hi0] cp0]. + eapply Mem.perm_free_1; eauto. left. intros EQ. subst. rewrite DWF1 in H. congruence. + } + intros MIFO. clear H0. + { destruct a; simpl in *. + - unfold mem_delta_apply_store in APPD. destruct d as [[[[ch0 b0] ofs0] v0] cp0]. + destruct (Pos.eqb_spec b b0). + + subst b0. unfold mem_delta_inj_store_fo in DFO1. + destruct (j b) eqn:JB. 2: congruence. clear H. destruct p. + unfold loc_first_order in *. clear MIFO APPD. + + + +Mem.store_mem_contents: + forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) + (cp : compartment) (m2 : mem), + Mem.store chunk m1 b ofs v cp = Some m2 -> + Mem.mem_contents m2 = + PMap.set b (Mem.setN (encode_val chunk v) ofs (Mem.mem_contents m1) !! b) (Mem.mem_contents m1) + + + + eapply Mem.perm_store_1; eauto. + - unfold mem_delta_apply_bytes in APPD. destruct d as [[[b0 ofs0] mvs0] cp0]. + eapply Mem.perm_storebytes_1; eauto. + - unfold mem_delta_apply_alloc in APPD. destruct d as [[cp0 lo0] hi0]. + destruct (Mem.alloc m_i cp0 lo0 hi0) eqn:CASES. inv APPD. + eapply Mem.perm_alloc_1; eauto. + - unfold mem_delta_apply_free in APPD. destruct d as [[[b0 lo0] hi0] cp0]. + eapply Mem.perm_free_1; eauto. left. intros EQ. subst. rewrite DWF1 in H. congruence. + } + + + + + rewrite DAM'. + destruct a. + - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. + destruct (j b) eqn:JB. + + destruct p as (b' & ofs'). eapply Mem.store_mapped_inject; eauto. + clear - DFO1. destruct v; auto. exfalso. simpl in *. destruct Archi.ptr64. + * destruct ch; simpl in *; try (inv DFO1; contradiction). + * destruct ch; simpl in *; try (inv DFO1; contradiction). + + exists m_i'; split; auto. eapply Mem.store_unmapped_inject; eauto. + - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. + exists m_i'; split; auto. eapply Mem.storebytes_unmapped_inject; eauto. + - destruct d0 as ((cp & lo) & hi). simpl in *. + exists m_i'; split; auto. destruct (Mem.alloc m_i cp lo hi) eqn:ALLOC. simpl in *. inv APPD. + eapply alloc_left_unmapped_inject_keep; eauto. + - destruct d0 as (((b & lo) & hi) & cp). simpl in *. + exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. + Qed. + + (* 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. + + + (DFO: mem_delta_inj_fo j d) + visible_fo_if_unknown ef ge m vargs -> + | None => visible_fo ge m (sig_args sg) args +visible_fo = +fun (ge : Senv.t) (m : mem) (tys : list typ) (args : list val) => +public_first_order ge m /\ vals_public ge tys args + : Senv.t -> mem -> list typ -> list val -> Prop +public_first_order = +fun (ge : Senv.t) (m : mem) => +forall (id : ident) (b : block) (ofs : Z), +Senv.public_symbol ge id = true -> +Senv.find_symbol ge id = Some b -> Mem.perm m b ofs Cur Readable -> loc_first_order m b ofs + : Senv.t -> mem -> Prop + + (* TODO: this is false --- pointers can mess around *) +(* Lemma val_inject_incr_inv *) +(* f f' v v' *) +(* (INCR: inject_incr f f') *) +(* (INJ: Val.inject f' v v') *) +(* : *) +(* Val.inject f v v'. *) +(* Proof. *) +(* inv INJ; auto. eapply Val.inject_ptr; auto. *) +(* val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' *) + + Lemma mem_inject_incr + f f' m m' + (INCR: inject_incr f f') + (INJ: Mem.inject f' m m') + : + Mem.inject f m m'. + Proof. + unfold Mem.inject in *. inv INJ. split; eauto. + 2:{ intros. specialize (mi_freeblocks _ H). unfold inject_incr in INCR. + destruct (f b) eqn:FB; auto. destruct p. specialize (INCR _ _ _ FB). + rewrite INCR in mi_freeblocks. inv mi_freeblocks. + } + 2:{ clear - INCR mi_no_overlap. unfold Mem.meminj_no_overlap in *. intros. + exploit mi_no_overlap; eauto. + } + clear - INCR mi_inj. inv mi_inj. split; eauto. intros. exploit mi_memval; eauto. intros. + eapply memval_inject_incr; eauto. + ` + +val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' +Unusedglobproof.regset_inject_incr: forall (f f' : meminj) (rs rs' : RTL.regset), Unusedglobproof.regset_inject f rs rs' -> inject_incr f f' -> Unusedglobproof.regset_inject f' rs rs' +memval_inject_incr: forall (f f' : meminj) (v1 v2 : memval), memval_inject f v1 v2 -> inject_incr f f' -> memval_inject f' v1 v2 +Stackingproof.agree_regs_inject_incr: forall (j : meminj) (ls : Linear.locset) (rs : Mach.regset) (j' : meminj), Stackingproof.agree_regs j ls rs -> inject_incr j j' -> Stackingproof.agree_regs j' ls rs +Cminorgenproof.match_temps_invariant: forall (f f' : meminj) (le : Csharpminor.temp_env) (te : Cminor.env), Cminorgenproof.match_temps f le te -> inject_incr f f' -> Cminorgenproof.match_temps f' le te +val_inject_list_incr: forall (f1 f2 : meminj) (vl vl' : list val), inject_incr f1 f2 -> Val.inject_list f1 vl vl' -> Val.inject_list f2 vl vl' + + +End MEMDELTA. From d3609dd4cc5fea8393816b1d9f959ff928a3185f Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 19 Jul 2023 17:32:37 +0200 Subject: [PATCH 076/174] WIP --- security/MemoryDelta.v | 138 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 138 insertions(+) diff --git a/security/MemoryDelta.v b/security/MemoryDelta.v index fe636cb71f..c695ca84f1 100644 --- a/security/MemoryDelta.v +++ b/security/MemoryDelta.v @@ -379,8 +379,146 @@ Section MEMDELTA. Qed. + (* Lemma nth_of_encode_val *) + (* ch v ofs ofs' *) + (* (GE: ofs <= ofs' < ofs + (size_chunk ch)) *) + (* : *) + (* exists mv, nth_error (encode_val ch v) (Z.to_nat (ofs' - ofs)) = Some mv. *) + (* Proof. *) + + 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. + revert ofs0 ofs 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. } + { eapply IHl. lia. } + 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 *. apply Mem.store_mem_contents in APPD1, APPD2. rewrite APPD1, APPD2. 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. auto. + 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_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. + + Definition mem_delta_kind_changed_by_store_inj (j: meminj) (k: mem_delta_kind) (b: block) (ofs: Z) := + match k with + | mem_delta_kind_store (ch0, b0, ofs0, v0, cp0) => + match j b0 with + | Some _ => mem_delta_changed_store (ch0, b0, ofs0, v0, cp0) b ofs + | _ => False + end + | _ => False + end. + + Definition mem_delta_changed_by_store_inj (j: meminj) (d: mem_delta) (b: block) (ofs: Z) := + Exists (fun k => mem_delta_kind_changed_by_store_inj j k b ofs) d. + + Lemma mem_delta_changed_only_by_store + j d b ofs + (INJ: j b <> None) + (CHG: mem_delta_changed d b ofs) + (WF: mem_delta_inj_wf j d) + : + mem_delta_changed_by_store_inj j d b ofs. + Proof. + + Abort. + + Lemma mem_delta_unchanged_or_changed + d b ofs + : + mem_delta_unchanged d b ofs \/ mem_delta_changed d b ofs. + Proof. + Abort. + + +(ZMap.get ofs (Mem.mem_contents m1) !! b1) +Mem.store_mem_contents: + forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) (m2 : mem), + Mem.store chunk m1 b ofs v cp = Some m2 -> Mem.mem_contents m2 = PMap.set b (Mem.setN (encode_val chunk v) ofs (Mem.mem_contents m1) !! b) (Mem.mem_contents m1) +Mem.setN_in: forall (vl : list memval) (p q : Z) (c : ZMap.t memval), p <= q < p + Z.of_nat (Datatypes.length vl) -> In (ZMap.get q (Mem.setN vl p c)) vl + + + + + + + +Mem.store_mem_contents: + forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) (m2 : mem), + Mem.store chunk m1 b ofs v cp = Some m2 -> Mem.mem_contents m2 = PMap.set b (Mem.setN (encode_val chunk v) ofs (Mem.mem_contents m1) !! b) (Mem.mem_contents m1) +Mem.storebytes_mem_contents: + forall (m1 : mem) (b : block) (ofs : Z) (bytes : list memval) (cp : compartment) (m2 : mem), + Mem.storebytes m1 b ofs bytes cp = Some m2 -> Mem.mem_contents m2 = PMap.set b (Mem.setN bytes ofs (Mem.mem_contents m1) !! b) (Mem.mem_contents m1) From a33c208ba68002bf32f179695862af5bacab20a9 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 20 Jul 2023 19:08:01 +0200 Subject: [PATCH 077/174] WIP --- security/MemoryDelta.v | 644 ++++++++++++++++++++++++++++------------- security/MemoryWeak.v | 92 ++++-- 2 files changed, 524 insertions(+), 212 deletions(-) diff --git a/security/MemoryDelta.v b/security/MemoryDelta.v index c695ca84f1..5af76d43a4 100644 --- a/security/MemoryDelta.v +++ b/security/MemoryDelta.v @@ -3,6 +3,156 @@ Require Import Coqlib Maps Errors Integers Values Memory Globalenvs. Require Import AST Linking Smallstep Events Behaviors. Require Import MemoryWeak. + + +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 *) @@ -139,6 +289,13 @@ Section MEMDELTA. destruct a; [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. + (* Lemma mem_delta_apply_eq *) (* d m0 *) (* : *) @@ -222,6 +379,13 @@ Section MEMDELTA. destruct a. destruct d0 as [[[[a0 a1] a2] a3] a4]. destruct (j a1). destruct p. rewrite mem_delta_apply_store_none. all: rewrite IHd; auto. Qed. + Lemma mem_delta_apply_inj_some + j d om m' + (APPD: mem_delta_apply_inj j d om = Some m') + : + exists m, om = Some m. + Proof. destruct om; eauto. rewrite mem_delta_apply_inj_none in APPD. inv APPD. Qed. + (* Lemma mem_delta_apply_inj_eq *) (* j d m0 *) (* : *) @@ -378,28 +542,72 @@ Section MEMDELTA. } Qed. + Lemma mem_delta_inj_unchanged_on + j d m m' + (STRICT: meminj_strict j) + (APPD: mem_delta_apply_inj j d (Some m) = Some m') + : + Mem.unchanged_on (fun b ofs => (forall b0 ofsd, j b0 <> Some (b, ofsd)) \/ (exists b0 ofsd, j b0 = Some (b, ofsd) /\ mem_delta_unchanged d b0 (ofs - ofsd))) 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_inj_cons in APPD. destruct a. + - destruct d0 as [[[[ch b] ofs] v] cp]. destruct (j b) as [[b' ofs'] |] eqn:JB. + + exploit mem_delta_apply_inj_some. eauto. intros (mi & MEM). rewrite MEM in APPD. + specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. + 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H; eauto. destruct H1 as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. right. eauto. } + { simpl in *. eapply Mem.store_unchanged_on. eauto. intros. intros [CC | CC]. + - specialize (CC b ofs'). congruence. + - destruct CC as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. simpl in H2. destruct (Pos.eqb_spec b b1). + + subst b1. rewrite JB in JB1. inv JB1. specialize (H2 eq_refl). lia. + + specialize (STRICT _ _ _ _ _ JB JB1). subst b1. lia. + } + + specialize (IHd _ _ APPD). eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H; eauto. destruct H1 as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. right. eauto. + - specialize (IHd _ _ APPD). eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H; eauto. destruct H1 as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. right. eauto. + - specialize (IHd _ _ APPD). eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H; eauto. destruct H1 as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. right. eauto. + - specialize (IHd _ _ APPD). eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H; eauto. destruct H1 as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. right. eauto. + Qed. - (* Lemma nth_of_encode_val *) - (* ch v ofs ofs' *) - (* (GE: ofs <= ofs' < ofs + (size_chunk ch)) *) - (* : *) - (* exists mv, nth_error (encode_val ch v) (Z.to_nat (ofs' - ofs)) = Some mv. *) - (* Proof. *) - Lemma get_from_setN_same - ofs0 ofs l + 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 (Mem.setN l ofs0 mc2). + ZMap.get ofs (Mem.setN l ofs0 mc1) = ZMap.get (ofs + ofsd) (Mem.setN l (ofs0 + ofsd) mc2). Proof. - revert ofs0 ofs OFS mc1 mc2. induction l; simpl; intros. + 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. } - { eapply IHl. lia. } + { 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_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)). @@ -414,10 +622,8 @@ Section MEMDELTA. 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 *. apply Mem.store_mem_contents in APPD1, APPD2. rewrite APPD1, APPD2. 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. auto. + 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 := @@ -469,202 +675,255 @@ Section MEMDELTA. Definition mem_delta_changed (d: mem_delta) (b: block) (ofs: Z) := Exists (fun k => mem_delta_kind_changed k b ofs) d. - Definition mem_delta_kind_changed_by_store_inj (j: meminj) (k: mem_delta_kind) (b: block) (ofs: Z) := - match k with - | mem_delta_kind_store (ch0, b0, ofs0, v0, cp0) => - match j b0 with - | Some _ => mem_delta_changed_store (ch0, b0, ofs0, v0, cp0) b ofs - | _ => False - end - | _ => False - end. + (* Definition mem_delta_kind_changed_by_store_inj (j: meminj) (k: mem_delta_kind) (b: block) (ofs: Z) := *) + (* match k with *) + (* | mem_delta_kind_store (ch0, b0, ofs0, v0, cp0) => *) + (* match j b0 with *) + (* | Some _ => mem_delta_changed_store (ch0, b0, ofs0, v0, cp0) b ofs *) + (* | _ => False *) + (* end *) + (* | _ => False *) + (* end. *) - Definition mem_delta_changed_by_store_inj (j: meminj) (d: mem_delta) (b: block) (ofs: Z) := - Exists (fun k => mem_delta_kind_changed_by_store_inj j k b ofs) d. + (* Definition mem_delta_changed_by_store_inj (j: meminj) (d: mem_delta) (b: block) (ofs: Z) := *) + (* Exists (fun k => mem_delta_kind_changed_by_store_inj j k b ofs) d. *) - Lemma mem_delta_changed_only_by_store - j d b ofs - (INJ: j b <> None) - (CHG: mem_delta_changed d b ofs) - (WF: mem_delta_inj_wf j d) + (** Propperties *) + Lemma mem_delta_cases_store + d b ofs : - mem_delta_changed_by_store_inj j d b ofs. - Proof. - - Abort. + 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_unchanged_or_changed + Lemma mem_delta_cases_bytes d b ofs : - mem_delta_unchanged d b ofs \/ mem_delta_changed d b ofs. - Proof. - Abort. + 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. -(ZMap.get ofs (Mem.mem_contents m1) !! b1) -Mem.store_mem_contents: - forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) (m2 : mem), - Mem.store chunk m1 b ofs v cp = Some m2 -> Mem.mem_contents m2 = PMap.set b (Mem.setN (encode_val chunk v) ofs (Mem.mem_contents m1) !! b) (Mem.mem_contents m1) -Mem.setN_in: forall (vl : list memval) (p q : Z) (c : ZMap.t memval), p <= q < p + Z.of_nat (Datatypes.length vl) -> In (ZMap.get q (Mem.setN vl p c)) vl + 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_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. + Lemma mem_delta_changed_only_by_store + j d b ofs + (STRICT: meminj_strict j) + b' ofsd + (INJ: j b = Some (b', ofsd)) + (WF: mem_delta_inj_wf j d) + (CHG: mem_delta_changed d b ofs) + m1 m1' m2 m2' + (PERM1: Mem.perm m1 b ofs Cur Readable) + (PERM2: Mem.perm m2 b' (ofs + ofsd) Cur Readable) + (APPD1: mem_delta_apply d (Some m1) = Some m1') + (APPD2: mem_delta_apply_inj j d (Some m2) = Some m2') + : + ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get (ofs + ofsd) (Mem.mem_contents m2') !! b'. + Proof. + revert WF CHG m1 m1' m2 m2' PERM1 PERM2 APPD1 APPD2. induction d; intros. + { inv CHG. } + rewrite mem_delta_apply_cons in APPD1. rewrite mem_delta_apply_inj_cons in APPD2. inv WF. rename H1 into WF1, H2 into WF2. inv CHG. + 2:{ specialize (IHd WF2 H0). destruct a. + - destruct d0 as [[[[ch0 b0 ]ofs0] v0] cp0]. destruct (j b0) as [[b0' ofs0'] |] eqn:JB. + + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. + exploit mem_delta_apply_inj_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. + simpl in *. eapply IHd. 3,4: eauto. 1,2: eapply Mem.perm_store_1; eauto. + + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. simpl in *. eapply IHd. 3,4: eauto. all: auto. 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. 3,4: eauto. all: auto. + 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. 3,4: eauto. all: auto. + destruct (Mem.alloc m1 x y z) eqn:ALLOC. simpl in MEM1. 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. 3,4: eauto. all: auto. + eapply Mem.perm_free_1; eauto. left. intros CC. subst. congruence. + } + rename H0 into CHG. destruct (mem_delta_unchanged_or_changed d b ofs). + 2:{ specialize (IHd WF2 H). destruct a. + - destruct d0 as [[[[ch0 b0 ]ofs0] v0] cp0]. destruct (j b0) as [[b0' ofs0'] |] eqn:JB. + + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. + exploit mem_delta_apply_inj_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. + simpl in *. eapply IHd. 3,4: eauto. 1,2: eapply Mem.perm_store_1; eauto. + + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. simpl in *. eapply IHd. 3,4: eauto. all: auto. 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. 3,4: eauto. all: auto. + 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. 3,4: eauto. all: auto. + destruct (Mem.alloc m1 x y z) eqn:ALLOC. simpl in MEM1. 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. 3,4: eauto. all: auto. + eapply Mem.perm_free_1; eauto. left. intros CC. subst. congruence. + } + rename H into UNCHG. clear IHd. + { destruct a. + - destruct d0 as [[[[ch0 b0] ofs0] v0] cp0]. destruct CHG as [CHG0 CHG1]. subst b0. rewrite INJ in APPD2. + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. exploit mem_delta_apply_inj_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. + simpl in *. + eapply mem_delta_unchanged_on in APPD1. exploit (Mem.unchanged_on_contents _ _ _ APPD1 b ofs); auto. + { eapply Mem.perm_store_1; eauto. } + intros. rewrite H; clear H. + eapply mem_delta_inj_unchanged_on in APPD2; auto. exploit (Mem.unchanged_on_contents _ _ _ APPD2 b' (ofs + ofsd)); auto. + { right. exists b, ofsd. split; auto. replace (ofs + ofsd - ofsd) with ofs by lia. auto. } + { eapply Mem.perm_store_1; eauto. } + intros. rewrite H; clear H. + eapply mem_store_same_upto_ofs; eauto. + - destruct d0 as [[[w x] y] z]. simpl in *. destruct CHG as [CHG0 CHG1]. subst w. rewrite WF1 in INJ. inv INJ. + - destruct d0 as [[x y] z]. simpl in *. inv CHG. + - destruct d0 as [[[w x] y] z]. simpl in *. inv CHG. rewrite WF1 in INJ. inv INJ. + } + Qed. + (* Lemma mem_delta_changed_only_by_store *) + (* j d b ofs *) + (* (INJ: j b <> None) *) + (* (CHG: mem_delta_changed d b ofs) *) + (* (WF: mem_delta_inj_wf j d) *) + (* : *) + (* mem_delta_changed_by_store_inj j d b ofs. *) + (* Proof. *) + (* Abort. *) + (* Lemma mem_delta_apply_store_preserves_winject *) + (* (j: meminj) m0 m0' *) + (* (WINJ0: winject j m0 m0') *) + (* ch b ofs v cp *) + (* m0 m1 *) + (* (MEM: mem_delta_apply_store (Some m0) (ch, b, ofs, v, cp) = Some m1) *) + (* : *) + (* exists m1', mem_delta_apply_store_inj *) + (* exists m1' : mem, mem_delta_apply_inj j d (mem_delta_apply_store (Some m0') (ch, b', ofs + ofs', v, cp)) = Some m1' /\ winject j m1 m1' *) -Mem.store_mem_contents: - forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) (m2 : mem), - Mem.store chunk m1 b ofs v cp = Some m2 -> Mem.mem_contents m2 = PMap.set b (Mem.setN (encode_val chunk v) ofs (Mem.mem_contents m1) !! b) (Mem.mem_contents m1) -Mem.storebytes_mem_contents: - forall (m1 : mem) (b : block) (ofs : Z) (bytes : list memval) (cp : compartment) (m2 : mem), - Mem.storebytes m1 b ofs bytes cp = Some m2 -> Mem.mem_contents m2 = PMap.set b (Mem.setN bytes ofs (Mem.mem_contents m1) !! b) (Mem.mem_contents m1) + Lemma mem_delta_apply_preserves_winject + (j: meminj) m0 m0' + (WINJ0: winject j m0 m0') + (d: mem_delta) + (DWF: mem_delta_inj_wf j d) + m1 + (APPD: mem_delta_apply d (Some m0) = Some m1) + : + exists m1', (mem_delta_apply_inj j d (Some m0') = Some m1') /\ (winject j m1 m1'). + Proof. + revert m0 m0' WINJ0 DWF m1 APPD. induction d; intros. + { inv APPD. simpl. exists m0'. split; auto. } + inv DWF. rename H1 into DWF1, H2 into DWF0. rewrite mem_delta_apply_cons in APPD. rewrite mem_delta_apply_inj_cons. + destruct a. + - destruct d0 as ((((ch & b) & ofs) & v) & cp). exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. + destruct (j b) as [[b' ofs']|] eqn:JB. + + exploit store_mapped_winject; eauto. instantiate (1:=v). intros (mi0 & MEM' & WINJ1). specialize (IHd _ _ WINJ1 DWF0 _ APPD). destruct IHd as (m1' & APPD' & WINJ'). + simpl in *. rewrite MEM'. eauto. + + exploit store_unmapped_winject; eauto. + - destruct d0 as (((b & ofs) & mvs) & cp). exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. exploit storebytes_unmapped_winject; eauto. + - destruct d0 as ((cp & lo) & hi). exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. simpl in *. + 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. exploit free_left_winject; eauto. + Qed. + Lemma mem_delta_apply_keeps_perm + j d + (DWF: mem_delta_inj_wf 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 & 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. + Definition meminj_not_alloc (j: meminj) (m: mem) := forall b, (Mem.nextblock m <= b)%positive -> j b = None. + Lemma mem_delta_apply_establish_inject + (k j: meminj) m0 m0' + (INJ: Mem.inject k m0 m0') + (INCR: inject_incr j k) + (STRICT: meminj_strict j) + (NALLOC: meminj_not_alloc j m0) + (d: mem_delta) + (DWF: mem_delta_inj_wf j d) + m1 + (APPD: mem_delta_apply d (Some m0) = Some m1) + : + exists m1', (mem_delta_apply_inj j d (Some m0') = Some m1') /\ (Mem.inject j 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; auto. + 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 (j b1 = None). + { eapply NALLOC. lia. } + congruence. + } + intros PERM0. + destruct (mem_delta_unchanged_or_changed d b1 ofs). + - exploit mem_delta_unchanged_on; eauto. intros UNCHG1. exploit mem_delta_inj_unchanged_on; eauto. intros UNCHG2. + erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1). erewrite (Mem.unchanged_on_contents _ _ _ UNCHG2). all: eauto. + 2:{ right. exists b1, delta. split; auto. replace (ofs + delta - delta) with ofs by lia. auto. } + { inv INJ. inv mi_inj. eapply mi_memval. + (* TODO *) + + { clear - INJ INCR - Mem.unchanged_on_contents: + + eauto + .unchanged_on_contents: forall (P : block -> Z -> Prop) (m_before m_after : mem), Mem.unchanged_on P m_before m_after -> forall (b : block) (ofs : Z), P b ofs -> Mem.perm m_before b ofs Cur Readable -> ZMap.get ofs (Mem.mem_contents m_after) !! b = ZMap.get ofs (Mem.mem_contents m_before) !! b - - mi_memval : 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) }. - - -Mem.load_store_overlap: - forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) (m2 : mem) (chunk' : memory_chunk) (ofs' : Z) (cp' : option compartment) (v' : val), - Mem.store chunk m1 b ofs v cp = Some m2 -> - Mem.load chunk' m2 b ofs' cp' = Some v' -> - ofs' + size_chunk chunk' > ofs -> - ofs + size_chunk chunk > ofs' -> - exists (mv1 : memval) (mvl : list memval) (mv1' : memval) (mvl' : list memval), - shape_encoding chunk v (mv1 :: mvl) /\ shape_decoding chunk' (mv1' :: mvl') v' /\ (ofs' = ofs /\ mv1' = mv1 \/ ofs' > ofs /\ In mv1' mvl \/ ofs' < ofs /\ In mv1 mvl') - - - - (* Properties *) - 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. + + (d_pre d_post: mem_delta) + (DWFPRE: mem_delta_inj_wf j d_pre) + (DWFPOST: mem_delta_inj_wf j d_post) + m_m + (APPDPRE: mem_delta_apply_left d_pre (Some m_i) = Some m_m) + (WINJ: mem_weak_inject j m_m m0') + m_f + (APPDPOST: mem_delta_apply_left d_post (Some m_m) = Some m_f) + (MFO: meminj_first_order j m_f) + : + exists m1', (mem_delta_apply_inj j (d_pre ++ d_post) m0' = Some m1') /\ (Mem.inject j m_f m1'). 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. + + (* TODO *) Lemma mem_delta_apply_preserves_full (k j: meminj) m_i m0' @@ -684,7 +943,6 @@ Mem.load_store_overlap: Proof. - rewrite mem_delta_apply_eq in APPD. rewrite mem_delta_apply_inj_eq. rewrite mem_delta_inj_wf_rev in DWF. remember (rev d) as rd. clear d Heqrd. rename rd into d. revert m0 m0' INJ0 DWF APPD. induction d; intros. { unfold mem_delta_apply_inj_left. simpl. exists m0'. split; auto. unfold mem_delta_apply_left in APPD. simpl in APPD. inv APPD. auto. } @@ -725,6 +983,10 @@ Mem.load_store_overlap: exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. Qed. + + + + Lemma val_inject_incr_inv f f' v v' (INCR: inject_incr f f') @@ -893,12 +1155,6 @@ Mem.store_mem_contents: exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. Qed. - (* 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. (DFO: mem_delta_inj_fo j d) diff --git a/security/MemoryWeak.v b/security/MemoryWeak.v index 2942e12228..aaaa5db491 100644 --- a/security/MemoryWeak.v +++ b/security/MemoryWeak.v @@ -135,7 +135,6 @@ Section WINJ. store chunk m1 b1 ofs v1 cp = Some n1 -> meminj_no_overlap f m1 -> f b1 = Some (b2, delta) -> - Val.inject f v1 v2 -> exists n2, store chunk m2 b2 (ofs + delta) v2 cp = Some n2 /\ mem_winj f n1 n2. @@ -143,7 +142,7 @@ Section WINJ. intros. assert (valid_access m2 chunk b2 (ofs + delta) Writable (Some cp)). eapply valid_access_winj; eauto with mem. - destruct (valid_access_store _ _ _ _ _ v2 H4) as [n2 STORE]. + destruct (valid_access_store _ _ _ _ _ v2 H3) as [n2 STORE]. exists n2; split. auto. constructor. (* perm *) @@ -849,7 +848,6 @@ Section WINJ. winject f m1 m2 -> store chunk m1 b1 ofs v1 cp = Some n1 -> f b1 = Some (b2, delta) -> - Val.inject f v1 v2 -> exists n2, store chunk m2 b2 (ofs + delta) v2 cp = Some n2 /\ winject f n1 n2. @@ -867,7 +865,7 @@ Section WINJ. red; intros. eauto with mem. (* representable *) intros. eapply mwi_representable; try eassumption. - destruct H4; eauto with mem. + 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. @@ -1552,20 +1550,20 @@ Section WINJ. eapply owned_new_block; eauto. Qed. - Theorem store_winject_neutral: - forall chunk m b ofs v cp m' thr, - store chunk m b ofs v cp = Some m' -> - winject_neutral thr m -> - Plt b thr -> - Val.inject (flat_winj thr) v v -> - winject_neutral thr m'. - Proof. - intros; red. - exploit store_mapped_winj. eauto. eauto. apply flat_winj_no_overlap. - unfold flat_winj. apply pred_dec_true; auto. eauto. - replace (ofs + 0) with ofs by lia. - intros [m'' [A B]]. congruence. - Qed. + (* Theorem store_winject_neutral: *) + (* forall chunk m b ofs v cp m' thr, *) + (* store chunk m b ofs v cp = Some m' -> *) + (* winject_neutral thr m -> *) + (* Plt b thr -> *) + (* Val.inject (flat_winj thr) v v -> *) + (* winject_neutral thr m'. *) + (* Proof. *) + (* intros; red. *) + (* exploit store_mapped_winj. eauto. eauto. apply flat_winj_no_overlap. *) + (* unfold flat_winj. apply pred_dec_true; auto. eauto. *) + (* replace (ofs + 0) with ofs by lia. *) + (* intros [m'' [A B]]. congruence. *) + (* Qed. *) Theorem drop_winject_neutral: forall m b lo hi p cp m' thr, @@ -1581,3 +1579,61 @@ Section WINJ. 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. From 883f7d1b8edc1497f7d4e66afc9975b484d72d48 Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 21 Jul 2023 11:44:01 +0200 Subject: [PATCH 078/174] mem delta done --- common/Events.v | 33 +-- security/BtInfoAsm.v | 616 +---------------------------------------- security/MemoryDelta.v | 439 ++--------------------------- 3 files changed, 44 insertions(+), 1044 deletions(-) diff --git a/common/Events.v b/common/Events.v index e90e4c14a6..2d69acffb3 100644 --- a/common/Events.v +++ b/common/Events.v @@ -2190,21 +2190,22 @@ Section VISIBLE. end. - (* 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. + (* 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. diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 2929cc6d8f..76c7fbf350 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -11,608 +11,6 @@ Require Import MemoryWeak MemoryDelta. Require Import BtBasics. -(* Section MEMDELTA. *) - -(* (* Data to get injection by invoking correct Mem.store: inj + (apply delta) = inj *) *) -(* 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_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) *) -(* . *) - -(* (* Definition mem_delta_key := (block * Z)%type. *) *) -(* (* Definition mem_delta := list (mem_delta_key * mem_delta_kind). *) *) -(* Definition mem_delta := list mem_delta_kind. *) - -(* (* Definition mem_delta_key_eqb (k1 k2: mem_delta_key): bool := *) *) -(* (* let (b1, ofs1) := k1 in let (b2, ofs2) := k2 in andb (Pos.eqb b1 b2) (Z.eqb ofs1 ofs2). *) *) - -(* (* Definition mem_delta_get (d: mem_delta) (b: block) (ofs: Z): option mem_delta_kind := *) *) -(* (* match find (fun '(k, data) => mem_delta_key_eqb k (b, ofs)) d with | Some (k, data) => Some data | None => None end. *) *) - -(* 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 (d: mem_delta) (m0: mem) : option mem := *) -(* fold_right (fun data om => *) -(* match data with *) -(* | 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 *) -(* ) (Some m0) d. *) - -(* Lemma mem_delta_apply_cons *) -(* d m0 m k *) -(* (MEM: mem_delta_apply d m0 = Some m) *) -(* : *) -(* mem_delta_apply (k :: d) m0 = *) -(* match k with *) -(* | mem_delta_kind_store dd => mem_delta_apply_store (Some m) dd *) -(* | mem_delta_kind_bytes dd => mem_delta_apply_bytes (Some m) dd *) -(* | mem_delta_kind_alloc dd => mem_delta_apply_alloc (Some m) dd *) -(* | mem_delta_kind_free dd => mem_delta_apply_free (Some m) dd *) -(* end. *) -(* Proof. simpl. rewrite MEM. auto. Qed. *) - -(* Definition mem_delta_apply_left (d: mem_delta) (om0: option mem) : option mem := *) -(* fold_left (fun om data => *) -(* match data with *) -(* | 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 *) -(* ) d om0. *) - -(* Lemma mem_delta_apply_left_cons *) -(* d m0 k *) -(* : *) -(* mem_delta_apply_left (k :: d) m0 = *) -(* match k with *) -(* | mem_delta_kind_store dd => mem_delta_apply_left d (mem_delta_apply_store (m0) dd) *) -(* | mem_delta_kind_bytes dd => mem_delta_apply_left d (mem_delta_apply_bytes (m0) dd) *) -(* | mem_delta_kind_alloc dd => mem_delta_apply_left d (mem_delta_apply_alloc (m0) dd) *) -(* | mem_delta_kind_free dd => mem_delta_apply_left d (mem_delta_apply_free (m0) dd) *) -(* end. *) -(* Proof. simpl. destruct k; auto. Qed. *) - -(* Lemma mem_delta_apply_left_app *) -(* d0 d1 m0 *) -(* : *) -(* mem_delta_apply_left (d0 ++ d1) m0 = mem_delta_apply_left d1 (mem_delta_apply_left d0 m0). *) -(* Proof. *) -(* revert d1 m0. induction d0; intros. *) -(* { simpl. auto. } *) -(* rewrite <- app_comm_cons. rewrite ! mem_delta_apply_left_cons. destruct a; auto. *) -(* Qed. *) - -(* Lemma mem_delta_apply_eq *) -(* d m0 *) -(* : *) -(* mem_delta_apply d m0 = mem_delta_apply_left (rev d) (Some m0). *) -(* Proof. *) -(* rewrite <- (rev_involutive d) at 1. unfold mem_delta_apply, mem_delta_apply_left. rewrite fold_left_rev_right. f_equal. *) -(* Qed. *) - -(* (* Delta and injection relation *) *) -(* Definition mem_delta_kind_inj_wf (j: meminj): mem_delta_kind -> Prop := *) -(* fun data => *) -(* match data with *) -(* | 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 (j: meminj): mem_delta -> Prop := *) -(* fun d => Forall (fun data => mem_delta_kind_inj_wf j data) d. *) - -(* Lemma mem_delta_inj_wf_rev *) -(* j d *) -(* : *) -(* mem_delta_inj_wf j d <-> mem_delta_inj_wf j (rev d). *) -(* Proof. *) -(* unfold mem_delta_inj_wf. split; intros. apply Forall_rev; auto. rewrite <- rev_involutive. apply Forall_rev. auto. *) -(* Qed. *) - -(* 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 mem_delta_inj_store_fo (j: meminj) (data: mem_delta_store): Prop := *) *) -(* (* let '(ch, b, ofs, v, cp) := data in *) *) -(* (* match j b with *) *) -(* (* | Some _ => Forall (fun mv => match mv with | Byte bt => True | _ => False end) (encode_val ch v) *) *) -(* (* | None => True *) *) -(* (* end. *) *) - -(* (* Definition mem_delta_inj_fo (j: meminj) (d: mem_delta): Prop := *) *) -(* (* Forall (fun data => *) *) -(* (* match data with *) *) -(* (* | mem_delta_kind_store d => mem_delta_inj_store_fo j d *) *) -(* (* | _ => True *) *) -(* (* end) d. *) *) - -(* Definition mem_delta_apply_inj (j: meminj) (d: mem_delta) (m0: mem) : option mem := *) -(* fold_right (fun data om => *) -(* match data with *) -(* | mem_delta_kind_store (ch, b, ofs, v, cp) => *) -(* match j b with *) -(* | Some (b', ofsd) => *) -(* mem_delta_apply_store om (ch, b', (ofs + ofsd)%Z, v, cp) *) -(* | None => om *) -(* end *) -(* | _ => om *) -(* end) (Some m0) d. *) - -(* Lemma mem_delta_apply_inj_cons *) -(* j d m0 m k *) -(* (MEM: mem_delta_apply_inj j d m0 = Some m) *) -(* : *) -(* mem_delta_apply_inj j (k :: d) m0 = *) -(* match k with *) -(* | mem_delta_kind_store (ch, b, ofs, v, cp) => *) -(* match j b with Some (b', ofsd) => mem_delta_apply_store (Some m) (ch, b', (ofs + ofsd)%Z, v, cp) | None => (Some m) end *) -(* | mem_delta_kind_bytes dd *) -(* | mem_delta_kind_alloc dd *) -(* | mem_delta_kind_free dd => Some m *) -(* end. *) -(* Proof. simpl. rewrite MEM. auto. Qed. *) - -(* Definition mem_delta_apply_inj_left (j: meminj) (d: mem_delta) (om0: option mem) : option mem := *) -(* fold_left (fun om data => *) -(* match data with *) -(* | mem_delta_kind_store (ch, b, ofs, v, cp) => *) -(* match j b with *) -(* | Some (b', ofsd) => *) -(* mem_delta_apply_store om (ch, b', (ofs + ofsd)%Z, v, cp) *) -(* | None => om *) -(* end *) -(* | _ => om *) -(* end) d (om0). *) - -(* Lemma mem_delta_apply_inj_left_cons *) -(* j d m0 k *) -(* : *) -(* mem_delta_apply_inj_left j (k :: d) m0 = *) -(* match k with *) -(* | mem_delta_kind_store (ch, b, ofs, v, cp) => *) -(* match j b with *) -(* | Some (b', ofsd) => *) -(* mem_delta_apply_inj_left j d (mem_delta_apply_store m0 (ch, b', (ofs + ofsd)%Z, v, cp)) *) -(* | None => mem_delta_apply_inj_left j d m0 *) -(* end *) -(* | mem_delta_kind_bytes dd *) -(* | mem_delta_kind_alloc dd *) -(* | mem_delta_kind_free dd => mem_delta_apply_inj_left j d m0 *) -(* end. *) -(* Proof. simpl. destruct k; auto. destruct d0 as [[[[a0 a1] a2] a3] a4]. destruct (j a1); auto. destruct p. auto. Qed. *) - -(* Lemma mem_delta_apply_inj_left_app *) -(* j d0 d1 m0 *) -(* : *) -(* mem_delta_apply_inj_left j (d0 ++ d1) m0 = mem_delta_apply_inj_left j d1 (mem_delta_apply_inj_left j d0 m0). *) -(* Proof. *) -(* revert j d1 m0. induction d0; intros. *) -(* { simpl. auto. } *) -(* rewrite <- app_comm_cons. rewrite ! mem_delta_apply_inj_left_cons. destruct a; auto. *) -(* { destruct d as [[[[a0 a1] a2] a3] a4]. destruct (j a1); auto. destruct p; auto. } *) -(* Qed. *) - -(* Lemma mem_delta_apply_inj_eq *) -(* j d m0 *) -(* : *) -(* mem_delta_apply_inj j d m0 = mem_delta_apply_inj_left j (rev d) (Some m0). *) -(* Proof. *) -(* rewrite <- (rev_involutive d) at 1. unfold mem_delta_apply_inj, mem_delta_apply_inj_left. rewrite fold_left_rev_right. f_equal. *) -(* 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. *) - -(* Lemma mem_delta_apply_preserves_full *) -(* (k j: meminj) m_i m0' *) -(* (INJ0: Mem.inject k m_i m0') *) -(* (INCR: inject_incr j k) *) -(* (d_pre d_post: mem_delta) *) -(* (DWFPRE: mem_delta_inj_wf j d_pre) *) -(* (DWFPOST: mem_delta_inj_wf j d_post) *) -(* m_m *) -(* (APPDPRE: mem_delta_apply_left d_pre (Some m_i) = Some m_m) *) -(* (WINJ: mem_weak_inject j m_m m0') *) -(* m_f *) -(* (APPDPOST: mem_delta_apply_left d_post (Some m_m) = Some m_f) *) -(* (MFO: meminj_first_order j m_f) *) -(* : *) -(* exists m1', (mem_delta_apply_inj j (d_pre ++ d_post) m0' = Some m1') /\ (Mem.inject j m_f m1'). *) -(* Proof. *) - - - -(* rewrite mem_delta_apply_eq in APPD. rewrite mem_delta_apply_inj_eq. rewrite mem_delta_inj_wf_rev in DWF. remember (rev d) as rd. clear d Heqrd. rename rd into d. *) -(* revert m0 m0' INJ0 DWF APPD. induction d; intros. *) -(* { unfold mem_delta_apply_inj_left. simpl. exists m0'. split; auto. unfold mem_delta_apply_left in APPD. simpl in APPD. inv APPD. auto. } *) -(* inv DWF. rename H1 into DWF1, H2 into DWF0. *) -(* rewrite mem_delta_apply_left_cons in APPD. rewrite mem_delta_apply_inj_left_cons. *) - - - - - -(* revert DWF DFO m1 APPD. induction d; simpl; intros. *) -(* { inv APPD. exists m0'. split; auto. } *) -(* inv DWF. rename H1 into DWF1, H2 into DWF0. inv DFO. rename H1 into DFO1, H2 into DFO0. *) -(* destruct (mem_delta_apply d m0) eqn:DAM. *) -(* 2:{ destruct a; *) -(* [rewrite mem_delta_apply_store_none in APPD; inv APPD *) -(* | rewrite mem_delta_apply_bytes_none in APPD; inv APPD *) -(* | rewrite mem_delta_apply_alloc_none in APPD; inv APPD *) -(* | rewrite mem_delta_apply_free_none in APPD; inv APPD]. *) -(* } *) -(* rename m into m_i. *) -(* specialize (IHd DWF0 DFO0 _ (eq_refl)). destruct IHd as (m_i' & DAM' & INJ_I). *) -(* rewrite DAM'. *) -(* destruct a. *) -(* - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. *) -(* destruct (j b) eqn:JB. *) -(* + destruct p as (b' & ofs'). eapply Mem.store_mapped_inject; eauto. *) -(* clear - DFO1. destruct v; auto. exfalso. simpl in *. destruct Archi.ptr64. *) -(* * destruct ch; simpl in *; try (inv DFO1; contradiction). *) -(* * destruct ch; simpl in *; try (inv DFO1; contradiction). *) -(* + exists m_i'; split; auto. eapply Mem.store_unmapped_inject; eauto. *) -(* - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. *) -(* exists m_i'; split; auto. eapply Mem.storebytes_unmapped_inject; eauto. *) -(* - destruct d0 as ((cp & lo) & hi). simpl in *. *) -(* exists m_i'; split; auto. destruct (Mem.alloc m_i cp lo hi) eqn:ALLOC. simpl in *. inv APPD. *) -(* eapply alloc_left_unmapped_inject_keep; eauto. *) -(* - destruct d0 as (((b & lo) & hi) & cp). simpl in *. *) -(* exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. *) -(* Qed. *) - -(* Lemma val_inject_incr_inv *) -(* f f' v v' *) -(* (INCR: inject_incr f f') *) -(* (INJ: Val.inject f' v v') *) -(* : *) -(* Val.inject f v v'. *) -(* Proof. *) -(* inv INJ; auto. eapply Val.inject_ptr; auto. *) -(* val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' *) - -(* Lemma mem_inject_incr *) -(* f f' m m' *) -(* (INCR: inject_incr f f') *) -(* (INJ: Mem.inject f' m m') *) -(* : *) -(* Mem.inject f m m'. *) -(* Proof. *) -(* unfold Mem.inject in *. inv INJ. split; eauto. *) -(* 2:{ intros. specialize (mi_freeblocks _ H). unfold inject_incr in INCR. *) -(* destruct (f b) eqn:FB; auto. destruct p. specialize (INCR _ _ _ FB). *) -(* rewrite INCR in mi_freeblocks. inv mi_freeblocks. *) -(* } *) -(* 2:{ clear - INCR mi_no_overlap. unfold Mem.meminj_no_overlap in *. intros. *) -(* exploit mi_no_overlap; eauto. *) -(* } *) -(* clear - INCR mi_inj. inv mi_inj. split; eauto. intros. exploit mi_memval; eauto. intros. *) -(* eapply memval_inject_incr; eauto. *) -(* ` *) - -(* val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' *) -(* Unusedglobproof.regset_inject_incr: forall (f f' : meminj) (rs rs' : RTL.regset), Unusedglobproof.regset_inject f rs rs' -> inject_incr f f' -> Unusedglobproof.regset_inject f' rs rs' *) -(* memval_inject_incr: forall (f f' : meminj) (v1 v2 : memval), memval_inject f v1 v2 -> inject_incr f f' -> memval_inject f' v1 v2 *) -(* Stackingproof.agree_regs_inject_incr: forall (j : meminj) (ls : Linear.locset) (rs : Mach.regset) (j' : meminj), Stackingproof.agree_regs j ls rs -> inject_incr j j' -> Stackingproof.agree_regs j' ls rs *) -(* Cminorgenproof.match_temps_invariant: forall (f f' : meminj) (le : Csharpminor.temp_env) (te : Cminor.env), Cminorgenproof.match_temps f le te -> inject_incr f f' -> Cminorgenproof.match_temps f' le te *) -(* val_inject_list_incr: forall (f1 f2 : meminj) (vl vl' : list val), inject_incr f1 f2 -> Val.inject_list f1 vl vl' -> Val.inject_list f2 vl vl' *) - -(* Lemma mem_delta_apply_preserves_inj *) -(* (j: meminj) m0 m0' *) -(* (INJ0: Mem.inject j m0 m0') *) -(* (d: mem_delta) *) -(* (DWF: mem_delta_inj_wf j d) *) -(* (DFO: mem_delta_inj_fo j d) *) -(* m1 *) -(* (APPD: mem_delta_apply d m0 = Some m1) *) -(* : *) -(* exists m1', (mem_delta_apply_inj j d m0' = Some m1') /\ (Mem.inject j m1 m1'). *) -(* Proof. *) -(* revert DWF DFO m1 APPD. induction d; simpl; intros. *) -(* { inv APPD. exists m0'. split; auto. } *) -(* inv DWF. rename H1 into DWF1, H2 into DWF0. inv DFO. rename H1 into DFO1, H2 into DFO0. *) -(* destruct (mem_delta_apply d m0) eqn:DAM. *) -(* 2:{ destruct a; *) -(* [rewrite mem_delta_apply_store_none in APPD; inv APPD *) -(* | rewrite mem_delta_apply_bytes_none in APPD; inv APPD *) -(* | rewrite mem_delta_apply_alloc_none in APPD; inv APPD *) -(* | rewrite mem_delta_apply_free_none in APPD; inv APPD]. *) -(* } *) -(* rename m into m_i. *) -(* specialize (IHd DWF0 DFO0 _ (eq_refl)). destruct IHd as (m_i' & DAM' & INJ_I). *) -(* rewrite DAM'. *) -(* destruct a. *) -(* - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. *) -(* destruct (j b) eqn:JB. *) -(* + destruct p as (b' & ofs'). eapply Mem.store_mapped_inject; eauto. *) -(* clear - DFO1. destruct v; auto. exfalso. simpl in *. destruct Archi.ptr64. *) -(* * destruct ch; simpl in *; try (inv DFO1; contradiction). *) -(* * destruct ch; simpl in *; try (inv DFO1; contradiction). *) -(* + exists m_i'; split; auto. eapply Mem.store_unmapped_inject; eauto. *) -(* - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. *) -(* exists m_i'; split; auto. eapply Mem.storebytes_unmapped_inject; eauto. *) -(* - destruct d0 as ((cp & lo) & hi). simpl in *. *) -(* exists m_i'; split; auto. destruct (Mem.alloc m_i cp lo hi) eqn:ALLOC. simpl in *. inv APPD. *) -(* eapply alloc_left_unmapped_inject_keep; eauto. *) -(* - destruct d0 as (((b & lo) & hi) & cp). simpl in *. *) -(* exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. *) -(* Qed. *) - -(* 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. *) - -(* Lemma mem_delta_apply_preserves_inj_incr *) -(* (j k: meminj) m0 m0' *) -(* (INCR: inject_incr j k) *) -(* (INJ0: Mem.inject k m0 m0') *) -(* (d: mem_delta) *) -(* (DWF: mem_delta_inj_wf j d) *) -(* (DFO: mem_delta_inj_fo j d) *) -(* m1 *) -(* (APPD: mem_delta_apply d m0 = Some m1) *) -(* (MIFO: meminj_first_order j m1) *) -(* : *) -(* exists m1', (mem_delta_apply_inj j d m0' = Some m1') /\ (Mem.inject j m1 m1'). *) -(* Proof. *) -(* revert DWF DFO m1 APPD MIFO. induction d; simpl; intros. *) -(* { inv APPD. exists m0'. split; auto. admit. (* MIFO *) } *) -(* inv DWF. rename H1 into DWF1, H2 into DWF0. inv DFO. rename H1 into DFO1, H2 into DFO0. *) -(* destruct (mem_delta_apply d m0) eqn:DAM. *) -(* 2:{ destruct a; *) -(* [rewrite mem_delta_apply_store_none in APPD; inv APPD *) -(* | rewrite mem_delta_apply_bytes_none in APPD; inv APPD *) -(* | rewrite mem_delta_apply_alloc_none in APPD; inv APPD *) -(* | rewrite mem_delta_apply_free_none in APPD; inv APPD]. *) -(* } *) -(* rename m into m_i. *) -(* specialize (IHd DWF0 DFO0 _ (eq_refl)). destruct IHd as (m_i' & DAM' & INJ_I). *) -(* { unfold meminj_first_order in *. intros. rename d into deltas. *) -(* specialize (MIFO _ ofs H). exploit MIFO; clear MIFO. *) -(* { destruct a; simpl in *. *) -(* - unfold mem_delta_apply_store in APPD. destruct d as [[[[ch0 b0] ofs0] v0] cp0]. *) -(* eapply Mem.perm_store_1; eauto. *) -(* - unfold mem_delta_apply_bytes in APPD. destruct d as [[[b0 ofs0] mvs0] cp0]. *) -(* eapply Mem.perm_storebytes_1; eauto. *) -(* - unfold mem_delta_apply_alloc in APPD. destruct d as [[cp0 lo0] hi0]. *) -(* destruct (Mem.alloc m_i cp0 lo0 hi0) eqn:CASES. inv APPD. *) -(* eapply Mem.perm_alloc_1; eauto. *) -(* - unfold mem_delta_apply_free in APPD. destruct d as [[[b0 lo0] hi0] cp0]. *) -(* eapply Mem.perm_free_1; eauto. left. intros EQ. subst. rewrite DWF1 in H. congruence. *) -(* } *) -(* intros MIFO. clear H0. *) -(* { destruct a; simpl in *. *) -(* - unfold mem_delta_apply_store in APPD. destruct d as [[[[ch0 b0] ofs0] v0] cp0]. *) -(* destruct (Pos.eqb_spec b b0). *) -(* + subst b0. unfold mem_delta_inj_store_fo in DFO1. *) -(* destruct (j b) eqn:JB. 2: congruence. clear H. destruct p. *) -(* unfold loc_first_order in *. clear MIFO APPD. *) - - - -(* Mem.store_mem_contents: *) -(* forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) *) -(* (cp : compartment) (m2 : mem), *) -(* Mem.store chunk m1 b ofs v cp = Some m2 -> *) -(* Mem.mem_contents m2 = *) -(* PMap.set b (Mem.setN (encode_val chunk v) ofs (Mem.mem_contents m1) !! b) (Mem.mem_contents m1) *) - - - -(* eapply Mem.perm_store_1; eauto. *) -(* - unfold mem_delta_apply_bytes in APPD. destruct d as [[[b0 ofs0] mvs0] cp0]. *) -(* eapply Mem.perm_storebytes_1; eauto. *) -(* - unfold mem_delta_apply_alloc in APPD. destruct d as [[cp0 lo0] hi0]. *) -(* destruct (Mem.alloc m_i cp0 lo0 hi0) eqn:CASES. inv APPD. *) -(* eapply Mem.perm_alloc_1; eauto. *) -(* - unfold mem_delta_apply_free in APPD. destruct d as [[[b0 lo0] hi0] cp0]. *) -(* eapply Mem.perm_free_1; eauto. left. intros EQ. subst. rewrite DWF1 in H. congruence. *) -(* } *) - - - - -(* rewrite DAM'. *) -(* destruct a. *) -(* - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. *) -(* destruct (j b) eqn:JB. *) -(* + destruct p as (b' & ofs'). eapply Mem.store_mapped_inject; eauto. *) -(* clear - DFO1. destruct v; auto. exfalso. simpl in *. destruct Archi.ptr64. *) -(* * destruct ch; simpl in *; try (inv DFO1; contradiction). *) -(* * destruct ch; simpl in *; try (inv DFO1; contradiction). *) -(* + exists m_i'; split; auto. eapply Mem.store_unmapped_inject; eauto. *) -(* - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. *) -(* exists m_i'; split; auto. eapply Mem.storebytes_unmapped_inject; eauto. *) -(* - destruct d0 as ((cp & lo) & hi). simpl in *. *) -(* exists m_i'; split; auto. destruct (Mem.alloc m_i cp lo hi) eqn:ALLOC. simpl in *. inv APPD. *) -(* eapply alloc_left_unmapped_inject_keep; eauto. *) -(* - destruct d0 as (((b & lo) & hi) & cp). simpl in *. *) -(* exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. *) -(* Qed. *) - -(* (* 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. *) - - -(* (DFO: mem_delta_inj_fo j d) *) -(* visible_fo_if_unknown ef ge m vargs -> *) -(* | None => visible_fo ge m (sig_args sg) args *) -(* visible_fo = *) -(* fun (ge : Senv.t) (m : mem) (tys : list typ) (args : list val) => *) -(* public_first_order ge m /\ vals_public ge tys args *) -(* : Senv.t -> mem -> list typ -> list val -> Prop *) -(* public_first_order = *) -(* fun (ge : Senv.t) (m : mem) => *) -(* forall (id : ident) (b : block) (ofs : Z), *) -(* Senv.public_symbol ge id = true -> *) -(* Senv.find_symbol ge id = Some b -> Mem.perm m b ofs Cur Readable -> loc_first_order m b ofs *) -(* : Senv.t -> mem -> Prop *) - -(* (* TODO: this is false --- pointers can mess around *) *) -(* (* Lemma val_inject_incr_inv *) *) -(* (* f f' v v' *) *) -(* (* (INCR: inject_incr f f') *) *) -(* (* (INJ: Val.inject f' v v') *) *) -(* (* : *) *) -(* (* Val.inject f v v'. *) *) -(* (* Proof. *) *) -(* (* inv INJ; auto. eapply Val.inject_ptr; auto. *) *) -(* (* val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' *) *) - -(* Lemma mem_inject_incr *) -(* f f' m m' *) -(* (INCR: inject_incr f f') *) -(* (INJ: Mem.inject f' m m') *) -(* : *) -(* Mem.inject f m m'. *) -(* Proof. *) -(* unfold Mem.inject in *. inv INJ. split; eauto. *) -(* 2:{ intros. specialize (mi_freeblocks _ H). unfold inject_incr in INCR. *) -(* destruct (f b) eqn:FB; auto. destruct p. specialize (INCR _ _ _ FB). *) -(* rewrite INCR in mi_freeblocks. inv mi_freeblocks. *) -(* } *) -(* 2:{ clear - INCR mi_no_overlap. unfold Mem.meminj_no_overlap in *. intros. *) -(* exploit mi_no_overlap; eauto. *) -(* } *) -(* clear - INCR mi_inj. inv mi_inj. split; eauto. intros. exploit mi_memval; eauto. intros. *) -(* eapply memval_inject_incr; eauto. *) -(* ` *) - -(* val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' *) -(* Unusedglobproof.regset_inject_incr: forall (f f' : meminj) (rs rs' : RTL.regset), Unusedglobproof.regset_inject f rs rs' -> inject_incr f f' -> Unusedglobproof.regset_inject f' rs rs' *) -(* memval_inject_incr: forall (f f' : meminj) (v1 v2 : memval), memval_inject f v1 v2 -> inject_incr f f' -> memval_inject f' v1 v2 *) -(* Stackingproof.agree_regs_inject_incr: forall (j : meminj) (ls : Linear.locset) (rs : Mach.regset) (j' : meminj), Stackingproof.agree_regs j ls rs -> inject_incr j j' -> Stackingproof.agree_regs j' ls rs *) -(* Cminorgenproof.match_temps_invariant: forall (f f' : meminj) (le : Csharpminor.temp_env) (te : Cminor.env), Cminorgenproof.match_temps f le te -> inject_incr f f' -> Cminorgenproof.match_temps f' le te *) -(* val_inject_list_incr: forall (f1 f2 : meminj) (vl vl' : list val), inject_incr f1 f2 -> Val.inject_list f1 vl vl' -> Val.inject_list f2 vl vl' *) - - -(* End MEMDELTA. *) - Section BUNDLE. @@ -768,7 +166,7 @@ Section IR. (INTRA: Genv.type_of_call ge cp_cur cp_ext = Genv.InternalCall) (SIG: sg = ef_sig ef) d m1' - (MEM: mem_delta_apply_inj (meminj_public ge) d m1 = Some m1') + (MEM: mem_delta_apply_inj (meminj_public ge) d (Some m1) = Some m1') vargs vretv (EC: external_call ef ge vargs m1' tr vretv m2) (VISFO: visible_fo_and_unknown ef ge m1 vargs) @@ -781,7 +179,7 @@ Section IR. cp_cur (CURCP: cp_cur = Genv.find_comp ge (Vptr cur Ptrofs.zero)) d m1' - (MEM: mem_delta_apply_inj (meminj_public ge) d m1 = Some m1') + (MEM: mem_delta_apply_inj (meminj_public ge) d (Some m1) = Some m1') vargs vretv (EC: external_call ef ge vargs m1' tr vretv m2) (VISFO: visible_fo_and_unknown ef ge m1 vargs) @@ -820,7 +218,7 @@ Section IR. (TR: call_trace_vr ge cp cp' b vargs (sig_args sg) tr1 id evargs) (* external function part *) d m1' - (MEM: mem_delta_apply_inj (meminj_public ge) d m1 = Some m1') + (MEM: mem_delta_apply_inj (meminj_public ge) d (Some m1) = Some m1') tr2 m2 vretv (EC: external_call ef ge vargs m1' tr2 vretv m2) (VISFO: visible_fo_and_unknown ef ge m1 vargs) @@ -843,7 +241,7 @@ Section IR. (TR1: call_trace_vr ge cp cp' b vargs (sig_args sg) tr1 id evargs) (* external function part *) d m1' - (MEM: mem_delta_apply_inj (meminj_public ge) d m1 = Some m1') + (MEM: mem_delta_apply_inj (meminj_public ge) d (Some m1) = Some m1') tr2 m2 vretv (TR2: external_call ef ge vargs m1' tr2 vretv m2) (VISFO: visible_fo_and_unknown ef ge m1 vargs) @@ -930,7 +328,7 @@ Section INVS. Definition match_mem (ge: Senv.t) (d: mem_delta) (m0 m_i m_a: mem): Prop := let j := meminj_public ge in (Mem.inject j m0 m_i) /\ (mem_delta_inj_wf j d) /\ - (mem_delta_apply d m0 = Some m_a). + (mem_delta_apply d (Some m0) = Some m_a). Definition match_state (ge: Asm.genv) (m0: mem) (d: mem_delta) (ast: Asm.state) (ist: ir_state): Prop := @@ -976,9 +374,9 @@ Section FROMASM. (EXEC: exec_instr ge f i rs m cp = Next rs' m') m0 d (DELTA0: mem_delta_inj_wf (meminj_public ge) d) - (DELTA1: mem_delta_apply d m0 = Some m) + (DELTA1: mem_delta_apply d (Some m0) = Some m) : - exists d', (mem_delta_inj_wf (meminj_public ge) d') /\ (mem_delta_apply d' m0 = Some m'). + exists d', (mem_delta_inj_wf (meminj_public ge) d') /\ (mem_delta_apply d' (Some m0) = Some m'). Proof. (* TODO *) Admitted. diff --git a/security/MemoryDelta.v b/security/MemoryDelta.v index 5af76d43a4..ba43b302fe 100644 --- a/security/MemoryDelta.v +++ b/security/MemoryDelta.v @@ -225,28 +225,6 @@ Section MEMDELTA. 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 (d: mem_delta) (m0: mem) : option mem := *) - (* fold_right (fun data om => *) - (* match data with *) - (* | 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 *) - (* ) (Some m0) d. *) - - (* Lemma mem_delta_apply_cons *) - (* d m0 m k *) - (* (MEM: mem_delta_apply d m0 = Some m) *) - (* : *) - (* mem_delta_apply (k :: d) m0 = *) - (* match k with *) - (* | mem_delta_kind_store dd => mem_delta_apply_store (Some m) dd *) - (* | mem_delta_kind_bytes dd => mem_delta_apply_bytes (Some m) dd *) - (* | mem_delta_kind_alloc dd => mem_delta_apply_alloc (Some m) dd *) - (* | mem_delta_kind_free dd => mem_delta_apply_free (Some m) dd *) - (* end. *) - (* Proof. simpl. rewrite MEM. auto. Qed. *) Definition mem_delta_apply (d: mem_delta) (om0: option mem) : option mem := fold_left (fun om data => @@ -296,39 +274,6 @@ Section MEMDELTA. exists m, om = Some m. Proof. destruct om; eauto. rewrite mem_delta_apply_none in APPD. inv APPD. Qed. - (* Lemma mem_delta_apply_eq *) - (* d m0 *) - (* : *) - (* mem_delta_apply d m0 = mem_delta_apply_left (rev d) (Some m0). *) - (* Proof. *) - (* rewrite <- (rev_involutive d) at 1. unfold mem_delta_apply, mem_delta_apply_left. rewrite fold_left_rev_right. f_equal. *) - (* Qed. *) - - (* Definition mem_delta_apply_inj (j: meminj) (d: mem_delta) (m0: mem) : option mem := *) - (* fold_right (fun data om => *) - (* match data with *) - (* | mem_delta_kind_store (ch, b, ofs, v, cp) => *) - (* match j b with *) - (* | Some (b', ofsd) => *) - (* mem_delta_apply_store om (ch, b', (ofs + ofsd)%Z, v, cp) *) - (* | None => om *) - (* end *) - (* | _ => om *) - (* end) (Some m0) d. *) - - (* Lemma mem_delta_apply_inj_cons *) - (* j d m0 m k *) - (* (MEM: mem_delta_apply_inj j d m0 = Some m) *) - (* : *) - (* mem_delta_apply_inj j (k :: d) m0 = *) - (* match k with *) - (* | mem_delta_kind_store (ch, b, ofs, v, cp) => *) - (* match j b with Some (b', ofsd) => mem_delta_apply_store (Some m) (ch, b', (ofs + ofsd)%Z, v, cp) | None => (Some m) end *) - (* | mem_delta_kind_bytes dd *) - (* | mem_delta_kind_alloc dd *) - (* | mem_delta_kind_free dd => Some m *) - (* end. *) - (* Proof. simpl. rewrite MEM. auto. Qed. *) Definition mem_delta_apply_inj (j: meminj) (d: mem_delta) (om0: option mem) : option mem := fold_left (fun om data => @@ -386,14 +331,6 @@ Section MEMDELTA. exists m, om = Some m. Proof. destruct om; eauto. rewrite mem_delta_apply_inj_none in APPD. inv APPD. Qed. - (* Lemma mem_delta_apply_inj_eq *) - (* j d m0 *) - (* : *) - (* mem_delta_apply_inj j d m0 = mem_delta_apply_inj_left j (rev d) (Some m0). *) - (* Proof. *) - (* rewrite <- (rev_involutive d) at 1. unfold mem_delta_apply_inj, mem_delta_apply_inj_left. rewrite fold_left_rev_right. f_equal. *) - (* Qed. *) - (** Delta and injection relations *) @@ -419,19 +356,7 @@ Section MEMDELTA. 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 mem_delta_inj_store_fo (j: meminj) (data: mem_delta_store): Prop := *) - (* let '(ch, b, ofs, v, cp) := data in *) - (* match j b with *) - (* | Some _ => Forall (fun mv => match mv with | Byte bt => True | _ => False end) (encode_val ch v) *) - (* | None => True *) - (* end. *) - - (* Definition mem_delta_inj_fo (j: meminj) (d: mem_delta): Prop := *) - (* Forall (fun data => *) - (* match data with *) - (* | mem_delta_kind_store d => mem_delta_inj_store_fo j d *) - (* | _ => True *) - (* end) d. *) + Definition meminj_not_alloc (j: meminj) (m: mem) := forall b, (Mem.nextblock m <= b)%positive -> j b = None. (** Delta and location relations *) @@ -675,18 +600,6 @@ Section MEMDELTA. Definition mem_delta_changed (d: mem_delta) (b: block) (ofs: Z) := Exists (fun k => mem_delta_kind_changed k b ofs) d. - (* Definition mem_delta_kind_changed_by_store_inj (j: meminj) (k: mem_delta_kind) (b: block) (ofs: Z) := *) - (* match k with *) - (* | mem_delta_kind_store (ch0, b0, ofs0, v0, cp0) => *) - (* match j b0 with *) - (* | Some _ => mem_delta_changed_store (ch0, b0, ofs0, v0, cp0) b ofs *) - (* | _ => False *) - (* end *) - (* | _ => False *) - (* end. *) - - (* Definition mem_delta_changed_by_store_inj (j: meminj) (d: mem_delta) (b: block) (ofs: Z) := *) - (* Exists (fun k => mem_delta_kind_changed_by_store_inj j k b ofs) d. *) (** Propperties *) Lemma mem_delta_cases_store @@ -797,27 +710,6 @@ Section MEMDELTA. } Qed. - (* Lemma mem_delta_changed_only_by_store *) - (* j d b ofs *) - (* (INJ: j b <> None) *) - (* (CHG: mem_delta_changed d b ofs) *) - (* (WF: mem_delta_inj_wf j d) *) - (* : *) - (* mem_delta_changed_by_store_inj j d b ofs. *) - (* Proof. *) - (* Abort. *) - - - (* Lemma mem_delta_apply_store_preserves_winject *) - (* (j: meminj) m0 m0' *) - (* (WINJ0: winject j m0 m0') *) - (* ch b ofs v cp *) - (* m0 m1 *) - (* (MEM: mem_delta_apply_store (Some m0) (ch, b, ofs, v, cp) = Some m1) *) - (* : *) - (* exists m1', mem_delta_apply_store_inj *) - (* exists m1' : mem, mem_delta_apply_inj j d (mem_delta_apply_store (Some m0') (ch, b', ofs + ofs', v, cp)) = Some m1' /\ winject j m1 m1' *) - Lemma mem_delta_apply_preserves_winject (j: meminj) m0 m0' (WINJ0: winject j m0 m0') @@ -869,7 +761,17 @@ Section MEMDELTA. eapply Mem.perm_free_3; eauto. eapply IHd. erewrite Mem.nextblock_free; eauto. Qed. - Definition meminj_not_alloc (j: meminj) (m: mem) := forall b, (Mem.nextblock m <= b)%positive -> j b = None. + 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 (k j: meminj) m0 m0' @@ -881,6 +783,7 @@ Section MEMDELTA. (DWF: mem_delta_inj_wf j d) m1 (APPD: mem_delta_apply d (Some m0) = Some m1) + (FO: meminj_first_order j m1) : exists m1', (mem_delta_apply_inj j d (Some m0') = Some m1') /\ (Mem.inject j m1 m1'). Proof. @@ -897,316 +800,14 @@ Section MEMDELTA. - exploit mem_delta_unchanged_on; eauto. intros UNCHG1. exploit mem_delta_inj_unchanged_on; eauto. intros UNCHG2. erewrite (Mem.unchanged_on_contents _ _ _ UNCHG1). erewrite (Mem.unchanged_on_contents _ _ _ UNCHG2). all: eauto. 2:{ right. exists b1, delta. split; auto. replace (ofs + delta - delta) with ofs by lia. auto. } - { inv INJ. inv mi_inj. eapply mi_memval. - (* TODO *) - - { clear - INJ INCR - - - eauto - .unchanged_on_contents: - forall (P : block -> Z -> Prop) (m_before m_after : mem), - Mem.unchanged_on P m_before m_after -> - forall (b : block) (ofs : Z), P b ofs -> Mem.perm m_before b ofs Cur Readable -> ZMap.get ofs (Mem.mem_contents m_after) !! b = ZMap.get ofs (Mem.mem_contents m_before) !! b - - (d_pre d_post: mem_delta) - (DWFPRE: mem_delta_inj_wf j d_pre) - (DWFPOST: mem_delta_inj_wf j d_post) - m_m - (APPDPRE: mem_delta_apply_left d_pre (Some m_i) = Some m_m) - (WINJ: mem_weak_inject j m_m m0') - m_f - (APPDPOST: mem_delta_apply_left d_post (Some m_m) = Some m_f) - (MFO: meminj_first_order j m_f) - : - exists m1', (mem_delta_apply_inj j (d_pre ++ d_post) m0' = Some m1') /\ (Mem.inject j m_f m1'). - Proof. - - - (* TODO *) - - Lemma mem_delta_apply_preserves_full - (k j: meminj) m_i m0' - (INJ0: Mem.inject k m_i m0') - (INCR: inject_incr j k) - (d_pre d_post: mem_delta) - (DWFPRE: mem_delta_inj_wf j d_pre) - (DWFPOST: mem_delta_inj_wf j d_post) - m_m - (APPDPRE: mem_delta_apply_left d_pre (Some m_i) = Some m_m) - (WINJ: mem_weak_inject j m_m m0') - m_f - (APPDPOST: mem_delta_apply_left d_post (Some m_m) = Some m_f) - (MFO: meminj_first_order j m_f) - : - exists m1', (mem_delta_apply_inj j (d_pre ++ d_post) m0' = Some m1') /\ (Mem.inject j m_f m1'). - Proof. - - - rewrite mem_delta_apply_eq in APPD. rewrite mem_delta_apply_inj_eq. rewrite mem_delta_inj_wf_rev in DWF. remember (rev d) as rd. clear d Heqrd. rename rd into d. - revert m0 m0' INJ0 DWF APPD. induction d; intros. - { unfold mem_delta_apply_inj_left. simpl. exists m0'. split; auto. unfold mem_delta_apply_left in APPD. simpl in APPD. inv APPD. auto. } - inv DWF. rename H1 into DWF1, H2 into DWF0. - rewrite mem_delta_apply_left_cons in APPD. rewrite mem_delta_apply_inj_left_cons. - - - - - - revert DWF DFO m1 APPD. induction d; simpl; intros. - { inv APPD. exists m0'. split; auto. } - inv DWF. rename H1 into DWF1, H2 into DWF0. inv DFO. rename H1 into DFO1, H2 into DFO0. - destruct (mem_delta_apply d m0) eqn:DAM. - 2:{ destruct a; - [rewrite mem_delta_apply_store_none in APPD; inv APPD - | rewrite mem_delta_apply_bytes_none in APPD; inv APPD - | rewrite mem_delta_apply_alloc_none in APPD; inv APPD - | rewrite mem_delta_apply_free_none in APPD; inv APPD]. - } - rename m into m_i. - specialize (IHd DWF0 DFO0 _ (eq_refl)). destruct IHd as (m_i' & DAM' & INJ_I). - rewrite DAM'. - destruct a. - - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. - destruct (j b) eqn:JB. - + destruct p as (b' & ofs'). eapply Mem.store_mapped_inject; eauto. - clear - DFO1. destruct v; auto. exfalso. simpl in *. destruct Archi.ptr64. - * destruct ch; simpl in *; try (inv DFO1; contradiction). - * destruct ch; simpl in *; try (inv DFO1; contradiction). - + exists m_i'; split; auto. eapply Mem.store_unmapped_inject; eauto. - - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. - exists m_i'; split; auto. eapply Mem.storebytes_unmapped_inject; eauto. - - destruct d0 as ((cp & lo) & hi). simpl in *. - exists m_i'; split; auto. destruct (Mem.alloc m_i cp lo hi) eqn:ALLOC. simpl in *. inv APPD. - eapply alloc_left_unmapped_inject_keep; eauto. - - destruct d0 as (((b & lo) & hi) & cp). simpl in *. - exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. - Qed. - - - - - - Lemma val_inject_incr_inv - f f' v v' - (INCR: inject_incr f f') - (INJ: Val.inject f' v v') - : - Val.inject f v v'. - Proof. - inv INJ; auto. eapply Val.inject_ptr; auto. -val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' - - Lemma mem_inject_incr - f f' m m' - (INCR: inject_incr f f') - (INJ: Mem.inject f' m m') - : - Mem.inject f m m'. - Proof. - unfold Mem.inject in *. inv INJ. split; eauto. - 2:{ intros. specialize (mi_freeblocks _ H). unfold inject_incr in INCR. - destruct (f b) eqn:FB; auto. destruct p. specialize (INCR _ _ _ FB). - rewrite INCR in mi_freeblocks. inv mi_freeblocks. - } - 2:{ clear - INCR mi_no_overlap. unfold Mem.meminj_no_overlap in *. intros. - exploit mi_no_overlap; eauto. - } - clear - INCR mi_inj. inv mi_inj. split; eauto. intros. exploit mi_memval; eauto. intros. - eapply memval_inject_incr; eauto. - ` - -val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' -Unusedglobproof.regset_inject_incr: forall (f f' : meminj) (rs rs' : RTL.regset), Unusedglobproof.regset_inject f rs rs' -> inject_incr f f' -> Unusedglobproof.regset_inject f' rs rs' -memval_inject_incr: forall (f f' : meminj) (v1 v2 : memval), memval_inject f v1 v2 -> inject_incr f f' -> memval_inject f' v1 v2 -Stackingproof.agree_regs_inject_incr: forall (j : meminj) (ls : Linear.locset) (rs : Mach.regset) (j' : meminj), Stackingproof.agree_regs j ls rs -> inject_incr j j' -> Stackingproof.agree_regs j' ls rs -Cminorgenproof.match_temps_invariant: forall (f f' : meminj) (le : Csharpminor.temp_env) (te : Cminor.env), Cminorgenproof.match_temps f le te -> inject_incr f f' -> Cminorgenproof.match_temps f' le te -val_inject_list_incr: forall (f1 f2 : meminj) (vl vl' : list val), inject_incr f1 f2 -> Val.inject_list f1 vl vl' -> Val.inject_list f2 vl vl' - - Lemma mem_delta_apply_preserves_inj - (j: meminj) m0 m0' - (INJ0: Mem.inject j m0 m0') - (d: mem_delta) - (DWF: mem_delta_inj_wf j d) - (DFO: mem_delta_inj_fo j d) - m1 - (APPD: mem_delta_apply d m0 = Some m1) - : - exists m1', (mem_delta_apply_inj j d m0' = Some m1') /\ (Mem.inject j m1 m1'). - Proof. - revert DWF DFO m1 APPD. induction d; simpl; intros. - { inv APPD. exists m0'. split; auto. } - inv DWF. rename H1 into DWF1, H2 into DWF0. inv DFO. rename H1 into DFO1, H2 into DFO0. - destruct (mem_delta_apply d m0) eqn:DAM. - 2:{ destruct a; - [rewrite mem_delta_apply_store_none in APPD; inv APPD - | rewrite mem_delta_apply_bytes_none in APPD; inv APPD - | rewrite mem_delta_apply_alloc_none in APPD; inv APPD - | rewrite mem_delta_apply_free_none in APPD; inv APPD]. - } - rename m into m_i. - specialize (IHd DWF0 DFO0 _ (eq_refl)). destruct IHd as (m_i' & DAM' & INJ_I). - rewrite DAM'. - destruct a. - - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. - destruct (j b) eqn:JB. - + destruct p as (b' & ofs'). eapply Mem.store_mapped_inject; eauto. - clear - DFO1. destruct v; auto. exfalso. simpl in *. destruct Archi.ptr64. - * destruct ch; simpl in *; try (inv DFO1; contradiction). - * destruct ch; simpl in *; try (inv DFO1; contradiction). - + exists m_i'; split; auto. eapply Mem.store_unmapped_inject; eauto. - - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. - exists m_i'; split; auto. eapply Mem.storebytes_unmapped_inject; eauto. - - destruct d0 as ((cp & lo) & hi). simpl in *. - exists m_i'; split; auto. destruct (Mem.alloc m_i cp lo hi) eqn:ALLOC. simpl in *. inv APPD. - eapply alloc_left_unmapped_inject_keep; eauto. - - destruct d0 as (((b & lo) & hi) & cp). simpl in *. - exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. - Qed. - - 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. - - Lemma mem_delta_apply_preserves_inj_incr - (j k: meminj) m0 m0' - (INCR: inject_incr j k) - (INJ0: Mem.inject k m0 m0') - (d: mem_delta) - (DWF: mem_delta_inj_wf j d) - (DFO: mem_delta_inj_fo j d) - m1 - (APPD: mem_delta_apply d m0 = Some m1) - (MIFO: meminj_first_order j m1) - : - exists m1', (mem_delta_apply_inj j d m0' = Some m1') /\ (Mem.inject j m1 m1'). - Proof. - revert DWF DFO m1 APPD MIFO. induction d; simpl; intros. - { inv APPD. exists m0'. split; auto. admit. (* MIFO *) } - inv DWF. rename H1 into DWF1, H2 into DWF0. inv DFO. rename H1 into DFO1, H2 into DFO0. - destruct (mem_delta_apply d m0) eqn:DAM. - 2:{ destruct a; - [rewrite mem_delta_apply_store_none in APPD; inv APPD - | rewrite mem_delta_apply_bytes_none in APPD; inv APPD - | rewrite mem_delta_apply_alloc_none in APPD; inv APPD - | rewrite mem_delta_apply_free_none in APPD; inv APPD]. - } - rename m into m_i. - specialize (IHd DWF0 DFO0 _ (eq_refl)). destruct IHd as (m_i' & DAM' & INJ_I). - { unfold meminj_first_order in *. intros. rename d into deltas. - specialize (MIFO _ ofs H). exploit MIFO; clear MIFO. - { destruct a; simpl in *. - - unfold mem_delta_apply_store in APPD. destruct d as [[[[ch0 b0] ofs0] v0] cp0]. - eapply Mem.perm_store_1; eauto. - - unfold mem_delta_apply_bytes in APPD. destruct d as [[[b0 ofs0] mvs0] cp0]. - eapply Mem.perm_storebytes_1; eauto. - - unfold mem_delta_apply_alloc in APPD. destruct d as [[cp0 lo0] hi0]. - destruct (Mem.alloc m_i cp0 lo0 hi0) eqn:CASES. inv APPD. - eapply Mem.perm_alloc_1; eauto. - - unfold mem_delta_apply_free in APPD. destruct d as [[[b0 lo0] hi0] cp0]. - eapply Mem.perm_free_1; eauto. left. intros EQ. subst. rewrite DWF1 in H. congruence. + { inv INJ. inv mi_inj. specialize (mi_memval _ _ _ _ (INCR _ _ _ H) PERM0). eapply loc_first_order_always_memval_inject; eauto. + exploit FO. erewrite H. 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. } - intros MIFO. clear H0. - { destruct a; simpl in *. - - unfold mem_delta_apply_store in APPD. destruct d as [[[[ch0 b0] ofs0] v0] cp0]. - destruct (Pos.eqb_spec b b0). - + subst b0. unfold mem_delta_inj_store_fo in DFO1. - destruct (j b) eqn:JB. 2: congruence. clear H. destruct p. - unfold loc_first_order in *. clear MIFO APPD. - - - -Mem.store_mem_contents: - forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) - (cp : compartment) (m2 : mem), - Mem.store chunk m1 b ofs v cp = Some m2 -> - Mem.mem_contents m2 = - PMap.set b (Mem.setN (encode_val chunk v) ofs (Mem.mem_contents m1) !! b) (Mem.mem_contents m1) - - - - eapply Mem.perm_store_1; eauto. - - unfold mem_delta_apply_bytes in APPD. destruct d as [[[b0 ofs0] mvs0] cp0]. - eapply Mem.perm_storebytes_1; eauto. - - unfold mem_delta_apply_alloc in APPD. destruct d as [[cp0 lo0] hi0]. - destruct (Mem.alloc m_i cp0 lo0 hi0) eqn:CASES. inv APPD. - eapply Mem.perm_alloc_1; eauto. - - unfold mem_delta_apply_free in APPD. destruct d as [[[b0 lo0] hi0] cp0]. - eapply Mem.perm_free_1; eauto. left. intros EQ. subst. rewrite DWF1 in H. congruence. - } - - - - - rewrite DAM'. - destruct a. - - destruct d0 as ((((ch & b) & ofs) & v) & cp). simpl in *. - destruct (j b) eqn:JB. - + destruct p as (b' & ofs'). eapply Mem.store_mapped_inject; eauto. - clear - DFO1. destruct v; auto. exfalso. simpl in *. destruct Archi.ptr64. - * destruct ch; simpl in *; try (inv DFO1; contradiction). - * destruct ch; simpl in *; try (inv DFO1; contradiction). - + exists m_i'; split; auto. eapply Mem.store_unmapped_inject; eauto. - - destruct d0 as (((b & ofs) & mvs) & cp). simpl in *. - exists m_i'; split; auto. eapply Mem.storebytes_unmapped_inject; eauto. - - destruct d0 as ((cp & lo) & hi). simpl in *. - exists m_i'; split; auto. destruct (Mem.alloc m_i cp lo hi) eqn:ALLOC. simpl in *. inv APPD. - eapply alloc_left_unmapped_inject_keep; eauto. - - destruct d0 as (((b & lo) & hi) & cp). simpl in *. - exists m_i'; split; auto. eapply Mem.free_left_inject; eauto. + { inv WINJ. inv mwi_inj. eapply mwi_perm; eauto. } + - rename H1 into CHG. erewrite <- mem_delta_changed_only_by_store; eauto. + { exploit FO; eauto. rewrite H. congruence. intros. unfold loc_first_order in H1. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1); try contradiction. constructor. } + { inv WINJ. inv mwi_inj. eapply mwi_perm; eauto. } Qed. - - - (DFO: mem_delta_inj_fo j d) - visible_fo_if_unknown ef ge m vargs -> - | None => visible_fo ge m (sig_args sg) args -visible_fo = -fun (ge : Senv.t) (m : mem) (tys : list typ) (args : list val) => -public_first_order ge m /\ vals_public ge tys args - : Senv.t -> mem -> list typ -> list val -> Prop -public_first_order = -fun (ge : Senv.t) (m : mem) => -forall (id : ident) (b : block) (ofs : Z), -Senv.public_symbol ge id = true -> -Senv.find_symbol ge id = Some b -> Mem.perm m b ofs Cur Readable -> loc_first_order m b ofs - : Senv.t -> mem -> Prop - - (* TODO: this is false --- pointers can mess around *) -(* Lemma val_inject_incr_inv *) -(* f f' v v' *) -(* (INCR: inject_incr f f') *) -(* (INJ: Val.inject f' v v') *) -(* : *) -(* Val.inject f v v'. *) -(* Proof. *) -(* inv INJ; auto. eapply Val.inject_ptr; auto. *) -(* val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' *) - - Lemma mem_inject_incr - f f' m m' - (INCR: inject_incr f f') - (INJ: Mem.inject f' m m') - : - Mem.inject f m m'. - Proof. - unfold Mem.inject in *. inv INJ. split; eauto. - 2:{ intros. specialize (mi_freeblocks _ H). unfold inject_incr in INCR. - destruct (f b) eqn:FB; auto. destruct p. specialize (INCR _ _ _ FB). - rewrite INCR in mi_freeblocks. inv mi_freeblocks. - } - 2:{ clear - INCR mi_no_overlap. unfold Mem.meminj_no_overlap in *. intros. - exploit mi_no_overlap; eauto. - } - clear - INCR mi_inj. inv mi_inj. split; eauto. intros. exploit mi_memval; eauto. intros. - eapply memval_inject_incr; eauto. - ` - -val_inject_incr: forall (f1 f2 : meminj) (v v' : val), inject_incr f1 f2 -> Val.inject f1 v v' -> Val.inject f2 v v' -Unusedglobproof.regset_inject_incr: forall (f f' : meminj) (rs rs' : RTL.regset), Unusedglobproof.regset_inject f rs rs' -> inject_incr f f' -> Unusedglobproof.regset_inject f' rs rs' -memval_inject_incr: forall (f f' : meminj) (v1 v2 : memval), memval_inject f v1 v2 -> inject_incr f f' -> memval_inject f' v1 v2 -Stackingproof.agree_regs_inject_incr: forall (j : meminj) (ls : Linear.locset) (rs : Mach.regset) (j' : meminj), Stackingproof.agree_regs j ls rs -> inject_incr j j' -> Stackingproof.agree_regs j' ls rs -Cminorgenproof.match_temps_invariant: forall (f f' : meminj) (le : Csharpminor.temp_env) (te : Cminor.env), Cminorgenproof.match_temps f le te -> inject_incr f f' -> Cminorgenproof.match_temps f' le te -val_inject_list_incr: forall (f1 f2 : meminj) (vl vl' : list val), inject_incr f1 f2 -> Val.inject_list f1 vl vl' -> Val.inject_list f2 vl vl' - - End MEMDELTA. From a3de0351209d10db487009d7c6387e94ada82e5a Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 21 Jul 2023 18:27:38 +0200 Subject: [PATCH 079/174] WIP --- security/BtInfoAsm.v | 172 +++++++++++++++++++++++++++++++++++++------ 1 file changed, 150 insertions(+), 22 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 76c7fbf350..1f8b7b411a 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -325,17 +325,16 @@ Section INVS. Definition match_stack (ge: Asm.genv) (ik: ir_conts) (st: stack) := Forall2 (match_stackframe ge) ik st. - Definition match_mem (ge: Senv.t) (d: mem_delta) (m0 m_i m_a: mem): Prop := + Definition match_mem (ge: Senv.t) (k: meminj) (d: mem_delta) (m_a0 m_i m_a1: mem): Prop := let j := meminj_public ge in - (Mem.inject j m0 m_i) /\ (mem_delta_inj_wf j d) /\ - (mem_delta_apply d (Some m0) = Some m_a). + (Mem.inject k m_a0 m_i) /\ (inject_incr j k) /\ (meminj_not_alloc j m_a0) /\ + (mem_delta_inj_wf j d) /\ (mem_delta_apply d (Some m_a0) = Some m_a1). - Definition match_state (ge: Asm.genv) (m0: mem) (d: mem_delta) - (ast: Asm.state) (ist: ir_state): Prop := + 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) => (match_cur_stack cur ge sk) /\ (match_cur_regset cur ge rs) /\ - (match_stack ge ik sk) /\ (match_mem ge d m0 m_i m_a) + (match_stack ge ik sk) /\ (match_mem ge k d m_a0 m_i m_a) | _, _ => False end. @@ -368,9 +367,88 @@ End MEASURE. 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. + + Definition public_not_freeable ge m := forall b, (meminj_public ge b <> None) -> (~ Mem.perm m b 0 Cur Freeable). + Lemma mem_delta_exec_instr - ge f i rs m cp rs' m' + (ge: genv) f i rs m cp rs' m' (* comp_of f ? *) + (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 (meminj_public ge) d) @@ -378,8 +456,57 @@ Section FROMASM. : exists d', (mem_delta_inj_wf (meminj_public ge) d') /\ (mem_delta_apply d' (Some m0) = Some m'). Proof. - (* TODO *) - Admitted. + 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 = _ |- _ => + exists (d ++ [mem_delta_kind_store (ch, b, ofs, v, cp)]); split + end; + [apply Forall_app; split; [auto | constructor; simpl; 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. + - 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. apply Heqo0. lia. + - rewrite mem_delta_apply_app. rewrite DELTA1. simpl. auto. + } + { (* TODO *) +Mem.range_perm = +fun (m : mem) (b : block) (lo hi : Z) (k : perm_kind) (p : permission) => forall ofs : Z, (lo <= ofs < hi)%Z -> Mem.perm m b ofs k p + : mem -> block -> Z -> Z -> perm_kind -> permission -> Prop + + exists d. split; auto. rewrite DELTA1. + + assert (m' = m); cycle 1. + { exists d. subst m'. split; auto. } + clear - Heqo0 H. + apply Mem.free_result in Heqo0. subst m'. + destruct m. unfold Mem.unchecked_free. simpl. + assert (A: PMap.set b (fun (ofs : Z) (k : perm_kind) => if zle 0 ofs && zlt ofs sz then None else mem_access !! b ofs k) mem_access = mem_access). + { admit. } + rewrite A. + + + + f_equal. + apply ClassicalFacts.proof_irrelevance. Axioms.functional_extensionality_dep. + Qed. End FROMASM. @@ -391,18 +518,18 @@ Section PROOF. (* If main is External, treat it in a different case - the trace can start with Event_syscall, without a preceding Event_call *) Lemma asm_to_ir - cpm ge m0 + cpm ge 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 d - (MTST: match_state ge m0 d ast ist) + 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 m0. revert ast ast' tr WFGE WFASM STAR ist d MTST. + 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. (* empty case *) @@ -421,15 +548,15 @@ Section PROOF. } unfold match_state in MTST. destruct ist as [[[cur m_i] ik] |]. 2:{ inv MTST. } - destruct MTST as (MTST0 & MTST1 & MTST2 & MTST3). destruct MTST3 as (MEM0 & MEM1 & MEM2). - exploit mem_delta_exec_instr. eapply H3. eapply MEM1. eapply MEM2. intros (d' & MEM1' & MEM2'). + destruct MTST as (MTST0 & MTST1 & MTST2 & MTST3). destruct MTST3 as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4). + exploit mem_delta_exec_instr. eapply H3. eapply MEM3. eapply MEM4. intros (d' & MEM3' & MEM4'). 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 m0 d' (State st rs' m') (Some (cur, m_i, ik))). + assert (MTST': match_state ge k m_a0 d' (State st rs' m') (Some (cur, m_i, ik))). { clear IH. 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. @@ -455,14 +582,15 @@ Section PROOF. 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; eauto. intros FINDSYMB. (* reestablish meminj *) - exploit mem_delta_apply_preserves_inj. eapply MEM0. eapply MEM1'. - { admit. (* from VISFO *) } - eapply MEM2'. + exploit mem_delta_apply_establish_inject. eapply MEM0. eapply MEM1. + { admit. (* ez *) } + eapply MEM2. eapply MEM3'. eapply MEM4'. + { admit. (* use VISFO *) } intros (m1' & MEMAPPIR & MEMINJ'). exploit external_call_mem_inject. + 2:{ eapply H12. } + 2:{ eapply MEMINJ'. } { admit. } - { eapply H12. } - { eapply MEMINJ'. } { instantiate (1:=args). admit. } intros (f' & vres' & m2' & EXTCALL' & VALINJ' & MEMINJ'2 & _ & _ & INCRINJ & _). (* take a step *) @@ -475,7 +603,7 @@ Section PROOF. rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } - { admit. (* VISFO --- maybe case analysis first on unknowns? *) } + { (* TODO *) admit. (* VISFO --- maybe case analysis first on unknowns? *) } } (* steps --- ReturnState *) From d8c0f1fb478af7bea9e98511305497f20b60a38f Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 24 Jul 2023 18:58:33 +0200 Subject: [PATCH 080/174] WIP --- Makefile | 2 +- security/BtInfoAsm.v | 373 +++++++++++------ security/Tactics.v | 952 +++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 1209 insertions(+), 118 deletions(-) create mode 100644 security/Tactics.v diff --git a/Makefile b/Makefile index 6e863ada20..4abe50ca68 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 MemoryWeak.v MemoryDelta.v BtInfoAsm.v BtBasics.v BtFromAsm.v Backtranslation.v +SECURITY=RSC.v Split.v Blame.v Recomposition.v Tactics.v MemoryWeak.v MemoryDelta.v BtInfoAsm.v BtBasics.v BtFromAsm.v Backtranslation.v # Parser diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 1f8b7b411a..310b6d406d 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -7,6 +7,8 @@ Require Import Split. Require Import riscV.Machregs. Require Import riscV.Asm. Require Import Complements. + +Require Import Tactics. Require Import MemoryWeak MemoryDelta. Require Import BtBasics. @@ -280,67 +282,6 @@ Section AUX. End AUX. -Section INVS. - - 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 match_cur_stack (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). - - Variant match_stackframe (ge: Asm.genv) : ir_cont_type -> stackframe -> Prop := - | match_stackframe_intro - b1 b2 cp sg v ofs - (COMP: Genv.find_comp ge (Vptr b1 Ptrofs.zero) = Genv.find_comp ge (Vptr b2 Ptrofs.zero)) - : - match_stackframe ge (ir_cont b1) (Stackframe b2 cp sg v ofs). - Definition match_stack (ge: Asm.genv) (ik: ir_conts) (st: stack) := - Forall2 (match_stackframe ge) ik st. - - Definition match_mem (ge: Senv.t) (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) /\ - (mem_delta_inj_wf j d) /\ (mem_delta_apply d (Some m_a0) = Some m_a1). - - 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) => - (match_cur_stack cur ge sk) /\ (match_cur_regset cur ge rs) /\ - (match_stack ge ik sk) /\ (match_mem ge k d m_a0 m_i m_a) - | _, _ => False - end. - -End INVS. - - Section MEASURE. Inductive star_measure {genv state : Type} (step : genv -> state -> trace -> state -> Prop) (ge : genv) : nat -> state -> trace -> state -> Prop := @@ -443,7 +384,27 @@ Section FROMASM. end); simpl. - Definition public_not_freeable ge m := forall b, (meminj_public ge b <> None) -> (~ Mem.perm m b 0 Cur Freeable). + Definition public_not_freeable ge m := forall b, (meminj_public ge b <> None) -> (~ Mem.perm m b 0 Max Freeable). +(* Definition public_not_freeable ge m := forall b, (meminj_public ge b <> None) -> (~ Mem.perm m b 0 Cur Freeable). *) +(* Genv.alloc_global = *) +(* fun (F V : Type) (CF : has_comp F) (ge : Genv.t F V) (m : mem) (idg : ident * globdef F V) => *) +(* let (_, g) := idg in *) +(* match g with *) +(* | Gfun f => let (m1, b) := Mem.alloc m (comp_of f) 0 1 in Mem.drop_perm m1 b 0 1 Nonempty (comp_of f) *) +(* | Gvar v => *) +(* let init := gvar_init v in *) +(* let comp := gvar_comp v in *) +(* let sz := init_data_list_size init in *) +(* let (m1, b) := Mem.alloc m comp 0 sz in *) +(* match store_zeros m1 b 0 sz comp with *) +(* | Some m2 => match Genv.store_init_data_list ge m2 b 0 init comp with *) +(* | Some m3 => Mem.drop_perm m3 b 0 sz (Genv.perm_globvar v) comp *) +(* | None => None *) +(* end *) +(* | None => None *) +(* end *) +(* end *) +(* : forall F V : Type, has_comp F -> Genv.t F V -> mem -> ident * globdef F V -> option mem *) Lemma mem_delta_exec_instr (ge: genv) f i rs m cp rs' m' @@ -483,42 +444,132 @@ Section FROMASM. 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. apply Heqo0. lia. + 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. lia. - rewrite mem_delta_apply_app. rewrite DELTA1. simpl. auto. } - { (* TODO *) -Mem.range_perm = -fun (m : mem) (b : block) (lo hi : Z) (k : perm_kind) (p : permission) => forall ofs : Z, (lo <= ofs < hi)%Z -> Mem.perm m b ofs k p - : mem -> block -> Z -> Z -> perm_kind -> permission -> Prop - - exists d. split; auto. rewrite DELTA1. - - assert (m' = m); cycle 1. - { exists d. subst m'. split; auto. } - clear - Heqo0 H. - apply Mem.free_result in Heqo0. subst m'. - destruct m. unfold Mem.unchecked_free. simpl. - assert (A: PMap.set b (fun (ofs : Z) (k : perm_kind) => if zle 0 ofs && zlt ofs sz then None else mem_access !! b ofs k) mem_access = mem_access). - { admit. } - rewrite A. + { admit. } + Admitted. + 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 = _ |- _ => + unfold public_not_freeable in *; intros b' H' CC; specialize (NFREE _ H'); apply NFREE; eapply Mem.perm_store_2; eauto + end). + { unfold public_not_freeable in *; intros b' H' CC; specialize (NFREE _ H'); apply NFREE. eapply Mem.perm_alloc_4; eauto. + eapply Mem.perm_store_2; eauto. intros EQ; subst b'. apply H'. apply NALLOC. erewrite Mem.alloc_result; eauto. lia. + } + { unfold public_not_freeable in *; intros b' H' CC; specialize (NFREE _ H'); apply NFREE. eapply Mem.perm_free_3; eauto. } + Qed. - - f_equal. - apply ClassicalFacts.proof_irrelevance. Axioms.functional_extensionality_dep. + 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 & 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. End FROMASM. +Section INVS. + + 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 match_cur_stack (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). + + Variant match_stackframe (ge: Asm.genv) : ir_cont_type -> stackframe -> Prop := + | match_stackframe_intro + b1 b2 cp sg v ofs + (COMP: Genv.find_comp ge (Vptr b1 Ptrofs.zero) = Genv.find_comp ge (Vptr b2 Ptrofs.zero)) + : + match_stackframe ge (ir_cont b1) (Stackframe b2 cp sg v ofs). + Definition match_stack (ge: Asm.genv) (ik: ir_conts) (st: stack) := + Forall2 (match_stackframe ge) ik st. + + Definition match_mem (ge: Senv.t) (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 j d) /\ (mem_delta_apply d (Some m_a0) = Some m_a1). + + 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) => + (match_cur_stack cur ge sk) /\ (match_cur_regset cur ge rs) /\ + (match_stack ge ik sk) /\ (match_mem ge k d m_a0 m_i m_a) + | _, _ => False + end. + +End INVS. + + Section PROOF. - Ltac empty_case := do 2 eexists; split; [|constructor 1]; auto. + Import ListNotations. + + Ltac end_case := do 2 eexists; split; [|constructor 1]; auto. (* If main is External, treat it in a different case - the trace can start with Event_syscall, without a preceding Event_call *) Lemma asm_to_ir - cpm ge m_a0 + cpm (ge: genv) m_a0 ast ast' tr (WFGE: wf_ge ge) (WFASM: wf_asm ge ast) @@ -532,14 +583,15 @@ Section PROOF. 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. - (* empty case *) - { empty_case. } + (* end case *) + { end_case. } rename H0 into STAR. inv H; simpl. - - destruct (Genv.find_funct_ptr ge b') eqn:NEXTF. + - (** internal *) + destruct (Genv.find_funct_ptr ge b') eqn:NEXTF. (* no next function *) 2:{ move STAR after NEXTF. inv STAR. - (* empty case *) - { empty_case. } + (* end case *) + { end_case. } (* take a step *) { inv H. (* invalid *) @@ -548,10 +600,10 @@ Section PROOF. } unfold match_state in MTST. destruct ist as [[[cur m_i] ik] |]. 2:{ inv MTST. } - destruct MTST as (MTST0 & MTST1 & MTST2 & MTST3). destruct MTST3 as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4). - exploit mem_delta_exec_instr. eapply H3. eapply MEM3. eapply MEM4. intros (d' & MEM3' & MEM4'). + destruct MTST as (MTST0 & MTST1 & MTST2 & MTST3). destruct MTST3 as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5). + exploit mem_delta_exec_instr. eapply MEM3. eapply H3. eapply MEM4. eapply MEM5. intros (d' & MEM4' & MEM5'). destruct f0. - (* has next function --- internal *) + (** 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. @@ -563,49 +615,136 @@ Section PROOF. rewrite H1. auto. } split. auto. - { unfold match_mem; auto. } + { unfold match_mem. repeat (split; auto). eapply public_not_freeable_exec_instr. 3: eapply H3. all: auto. eapply meminj_not_alloc_delta; eauto. } } exploit IH. 4: eapply STAR. all: auto. eapply MTST'. intros (btr & ist' & UNTR & ISTAR). exists btr, ist'. split; auto. } - (* has next function --- external *) + (** has next function --- external *) { move STAR after NEXTF. inv STAR. - (* empty case *) - { empty_case. } + (* end case *) + { end_case. } (* take a step *) inv H. (* invalid *) 1,2,3,4: rewrite NEXTPC in H10; inv H10; rewrite NEXTF in H11; inv H11. - (* external call & InternalCall *) - { rewrite NEXTPC in H10; inv H10. rewrite NEXTF in H11; inv H11. - 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; eauto. intros FINDSYMB. - (* reestablish meminj *) - exploit mem_delta_apply_establish_inject. eapply MEM0. eapply MEM1. - { admit. (* ez *) } - eapply MEM2. eapply MEM3'. eapply MEM4'. - { admit. (* use VISFO *) } - intros (m1' & MEMAPPIR & MEMINJ'). - exploit external_call_mem_inject. - 2:{ eapply H12. } - 2:{ eapply MEMINJ'. } - { admit. } - { instantiate (1:=args). admit. } - intros (f' & vres' & m2' & EXTCALL' & VALINJ' & MEMINJ'2 & _ & _ & INCRINJ & _). - (* take a step *) - rename H6 into STEP1; move STEP1 after REC_CURCOMP. inv STEP1. - (* terminates *) - { exists ((Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')) :: nil). eexists. simpl. split; auto. + (** external & InternalCall *) + rewrite NEXTPC in H10; inv H10. rewrite NEXTF in H11; inv H11. + 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; eauto. intros FINDSYMB. + (* reestablish meminj *) + exploit mem_delta_apply_establish_inject. eapply MEM0. eapply MEM1. + { admit. (* ez *) } + eapply MEM2. eapply MEM4'. eapply MEM5'. + { admit. (* use VISFO *) } + intros (m1' & MEMAPPIR & MEMINJ'). + exploit external_call_mem_inject. + 2:{ eapply H12. } + 2:{ eapply MEMINJ'. } + { admit. } + { instantiate (1:=args). admit. } + intros (f' & vres' & m2' & EXTCALL' & VALINJ' & MEMINJ'2 & _ & _ & INCRINJ & _). + (* take a step *) + rename H6 into STAR; move STAR after REC_CURCOMP. inv STAR. + (** terminates *) + { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')]). eexists. simpl. split; auto. + econstructor 2. 2: econstructor 1. 2: auto. + eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. + { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. + rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. + unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. + } + { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } + } + (* steps --- ReturnState *) + inv H. inv EV; simpl in *. + (** return is nccc *) + { rename H6 into STAR, H into NCCC. rewrite Pregmap.gss in H13, PC_RA, RESTORE_SP, NO_CROSS_PTR, NCCC. + pose proof STAR as STAR0. inv STAR. + (* end case *) + { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')]). simpl. eexists. split; auto. econstructor 2. 2: econstructor 1. 2: auto. eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } - { (* TODO *) admit. (* VISFO --- maybe case analysis first on unknowns? *) } + { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } + } + (* has next step - if internal, done; if external, ub *) + rename H into STEP, H6 into STAR. destruct (rs' X1) eqn:NEXTPC2. + 1,2,3,4,5: inv STEP; rewrite Pregmap.gss in H8; inv H8. (* make a lemma *) + destruct (Genv.find_funct_ptr ge b1) eqn:NEXTF2. + 2:{ inv STEP; rewrite Pregmap.gss in H8; inv H8; rewrite NEXTF2 in H9; inv H9. (* make a lemma *) } + destruct f0. + (** next is internal *) + { exploit IH; clear IH. 4: eapply STAR0. lia. all: auto. + { simpl. destruct WFASM as [WFASM1 WFASM2]. split. + - unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pregmap.gss in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. + - unfold wf_regset in *. rewrite Pregmap.gss. rewrite NEXTF2. auto. + } + { instantiate (1:=Some (cur, m2', ik)). simpl. split. + { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pregmap.gss in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } + split. + { unfold match_cur_regset in *. rewrite Pregmap.gss. simpl in *. unfold Genv.type_of_call in NCCC. des_ifs. + rewrite MTST1. rewrite H0; simpl. apply Pos.eqb_eq in Heq. rewrite Heq. rewrite <- REC_CURCOMP. rewrite NEXTPC. simpl. rewrite <- ALLOWED. + unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite H1. auto. + } + split. + { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pregmap.gss in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } + { instantiate (3:=f'). instantiate (2:=[]). instantiate (1:=m'0). unfold match_mem. simpl. split; auto. split; auto. split. + { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. + pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. + } + split. + { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. pose proof (public_not_freeable_exec_instr _ _ _ _ _ _ _ _ MEM3 NALLOC H3) as NFREE. + pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC2. + clear - H12 NFREE NALLOC2. unfold public_not_freeable in *. intros. specialize (NFREE _ H). intros CC. apply NFREE; clear NFREE. + eapply external_call_max_perm; eauto. unfold Mem.valid_block. unfold meminj_not_alloc in NALLOC2. + unfold Plt. destruct (Pos.ltb_spec b (Mem.nextblock m')); auto. specialize (NALLOC2 _ H0). congruence. + } + split; auto. constructor. + } + } + intros (btr & ist' & UTR & ISTAR'). + (* FIX: case analysis on whether extcall is unknown or not *) + exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')] ++ btr), ist'. simpl. rewrite UTR. split; auto. + econstructor 2. 2: eapply ISTAR'. 2: auto. + eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. + { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. + rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. + unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. + } + { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } } - (* steps --- ReturnState *) + (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) + (* take a step *) + inv STEP. + (* invalid *) + 1,2,3,4: rewrite Pregmap.gss in H8; inv H8; rewrite NEXTF2 in H9; inv H9. + (** external & InternalCall & next PC is Vundef *) + rewrite Pregmap.gss in H8; inv H8. rewrite NEXTF2 in H9; inv H9. + assert (STUCK: ((set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (Vptr b2 Ptrofs.zero) X1) = Vundef). + { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } + rewrite STUCK in STAR. inv STAR. + (* end case *) + { admit. } + inv H; simpl in *. rewrite Pregmap.gss in *. inv H6. + (* end case *) + { admit. } + (* stuck case *) + inv H; simpl in *; rewrite Pregmap.gss in *; inv H11. + } + (** return is ccc --- next is poped from the stack, which is internal, so done *) + simpl in *. rewrite Pregmap.gss in *. + + + + + (* TODO *) + diff --git a/security/Tactics.v b/security/Tactics.v new file mode 100644 index 0000000000..4310c0f42e --- /dev/null +++ b/security/Tactics.v @@ -0,0 +1,952 @@ +(* *********************************************************************) +(* *) +(* Lemmas & Tactic form coq-sflib: *) +(* https://github.com/snu-sf/sflib/blob/master/sflib.v *) +(* *) +(* *********************************************************************) + +(** 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) + ]. From f4fd9e4ad897b0b1b5713cef2006ded0b14b5189 Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 25 Jul 2023 19:19:48 +0200 Subject: [PATCH 081/174] WIP --- security/BtInfoAsm.v | 241 +++++++++++++++++++++++++++++++++++-------- 1 file changed, 200 insertions(+), 41 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 310b6d406d..32ccb87cbf 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -78,18 +78,18 @@ Section EVENT. Definition typ_to_eventvals (ty: list typ): list eventval := map typ_to_eventval ty. - (* Definition genv_invert_symbol_total {F V : Type} (ge : Genv.t F V) : block -> ident := *) - (* fun b => match Genv.invert_symbol ge b with | Some i => i | None => xH end. *) - - (* only virtual (default) or real (cross) cases *) Inductive call_trace_vr {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> block -> list val -> list typ -> trace -> ident -> list eventval -> Prop := - | call_trace_vr_cross : forall (cp cp' : compartment) (b : block) (vargs : list val) (vl : list eventval) (ty : list typ) (i : ident), + | call_trace_vr_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 -> call_trace_vr ge cp cp' b vargs ty (Event_call cp cp' i vl :: nil) i vl. + Genv.invert_symbol ge b = Some i -> eventval_list_match ge vl ty vargs -> + (tr = Event_call cp cp' i vl :: nil) -> + call_trace_vr ge cp cp' b vargs ty tr i vl. Inductive return_trace_vr {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> val -> rettype -> trace -> eventval -> Prop := - | return_trace_vr_cross : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype), - Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> eventval_match ge res (proj_rettype ty) v -> return_trace_vr ge cp cp' v ty (Event_return cp cp' res :: nil) res. + | return_trace_vr_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_vr ge cp cp' v ty tr res. (* external call *) Definition senv_invert_symbol_total (ge: Senv.t) (b: block) : ident := @@ -140,7 +140,7 @@ Section IR. : ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg None) (Some (b, m1, (ir_cont cur) :: ik)) | ir_step_vr_return_internal - cur m1 next ik_tl + cur m1 next ik ik_tl tr evretv cp_cur cp_next vretv (CURCP: cp_cur = Genv.find_comp ge (Vptr cur Ptrofs.zero)) @@ -154,8 +154,9 @@ Section IR. (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_vr ge cp_next cp_cur vretv (sig_res sg) tr evretv) + (CONT: ik = (ir_cont next) :: ik_tl) : - ir_step ge (Some (cur, m1, ((ir_cont next) :: ik_tl))) (Bundle_return tr evretv) (Some (next, m1, ik_tl)) + ir_step ge (Some (cur, m1, ik)) (Bundle_return tr evretv) (Some (next, m1, ik_tl)) | ir_step_intra_call_external cur m1 m2 ik tr id evargs sg @@ -171,7 +172,7 @@ Section IR. (MEM: mem_delta_apply_inj (meminj_public ge) d (Some m1) = Some m1') vargs vretv (EC: external_call ef ge vargs m1' tr vretv m2) - (VISFO: visible_fo_and_unknown ef ge m1 vargs) + (VISFO: visible_fo_and_unknown ef ge m1' vargs) (ARGS: evargs = vals_to_eventvals ge vargs) : ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg (Some d)) (Some (cur, m2, ik)) @@ -184,7 +185,7 @@ Section IR. (MEM: mem_delta_apply_inj (meminj_public ge) d (Some m1) = Some m1') vargs vretv (EC: external_call ef ge vargs m1' tr vretv m2) - (VISFO: visible_fo_and_unknown ef ge m1 vargs) + (VISFO: visible_fo_and_unknown ef ge m1' vargs) (ARGS: evargs = vals_to_eventvals ge vargs) : ir_step ge (Some (cur, m1, ik)) (Bundle_builtin tr ef evargs d) (Some (cur, m2, ik)) @@ -223,7 +224,7 @@ Section IR. (MEM: mem_delta_apply_inj (meminj_public ge) d (Some m1) = Some m1') tr2 m2 vretv (EC: external_call ef ge vargs m1' tr2 vretv m2) - (VISFO: visible_fo_and_unknown ef ge m1 vargs) + (VISFO: visible_fo_and_unknown ef ge m1' vargs) (ARGS: evargs = vals_to_eventvals ge vargs) : ir_step ge (Some (cur, m1, ik)) (Bundle_call (tr1 ++ tr2) id evargs sg (Some d)) None @@ -246,7 +247,7 @@ Section IR. (MEM: mem_delta_apply_inj (meminj_public ge) d (Some m1) = Some m1') tr2 m2 vretv (TR2: external_call ef ge vargs m1' tr2 vretv m2) - (VISFO: visible_fo_and_unknown ef ge m1 vargs) + (VISFO: visible_fo_and_unknown ef ge m1' vargs) (ARGS: evargs = vals_to_eventvals ge vargs) (* return part *) tr3 evretv @@ -447,8 +448,9 @@ Section FROMASM. 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. lia. - rewrite mem_delta_apply_app. rewrite DELTA1. simpl. auto. } - { admit. } - Admitted. + { apply Mem.free_result in Heqo0. unfold Mem.unchecked_free in Heqo0. unfold zle in Heqo0. des_ifs. eexists; eauto. } + } + Qed. Lemma public_not_freeable_exec_instr (ge: genv) f i rs m cp rs' m' @@ -500,6 +502,8 @@ 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 @@ -525,6 +529,28 @@ Section INVS. 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 wf_ir (ge: Asm.genv) (ist: ir_state) := *) + (* match ist with *) + (* | Some (_, _, ik) => (wf_ir_conts ge ik) *) + (* | _ => False *) + (* end. *) + + Definition match_cur_stack (cur: block) (ge: Asm.genv) (sk: stack) := match Genv.find_funct_ptr ge cur with | Some fd => Asm.funsig fd = sig_of_call sk @@ -534,14 +560,27 @@ Section INVS. 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). - Variant match_stackframe (ge: Asm.genv) : ir_cont_type -> stackframe -> Prop := - | match_stackframe_intro - b1 b2 cp sg v ofs - (COMP: Genv.find_comp ge (Vptr b1 Ptrofs.zero) = Genv.find_comp ge (Vptr b2 Ptrofs.zero)) - : - match_stackframe ge (ir_cont b1) (Stackframe b2 cp sg v ofs). - Definition match_stack (ge: Asm.genv) (ik: ir_conts) (st: stack) := - Forall2 (match_stackframe ge) ik st. + 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 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). + + (* Variant match_stackframe (ge: Asm.genv) : ir_cont_type -> stackframe -> Prop := *) + (* | match_stackframe_intro *) + (* b1 b2 cp sg v ofs *) + (* (COMP: Genv.find_comp ge (Vptr b1 Ptrofs.zero) = Genv.find_comp ge (Vptr b2 Ptrofs.zero)) *) + (* : *) + (* match_stackframe ge (ir_cont b1) (Stackframe b2 cp sg v ofs). *) + (* Definition match_stack (ge: Asm.genv) (ik: ir_conts) (st: stack) := *) + (* Forall2 (match_stackframe ge) ik st. *) Definition match_mem (ge: Senv.t) (k: meminj) (d: mem_delta) (m_a0 m_i m_a1: mem): Prop := let j := meminj_public ge in @@ -552,7 +591,8 @@ Section INVS. 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) => - (match_cur_stack cur ge sk) /\ (match_cur_regset cur ge rs) /\ + (wf_ir_cur ge cur) /\ (wf_ir_conts ge ik) /\ + (match_cur_stack cur ge sk) /\ (match_cur_regset cur ge rs) /\ (match_stack ge ik sk) /\ (match_mem ge k d m_a0 m_i m_a) | _, _ => False end. @@ -566,7 +606,7 @@ Section PROOF. Ltac end_case := do 2 eexists; split; [|constructor 1]; auto. - (* If main is External, treat it in a different case - + (* If main is External, treat it as a different case - the trace can start with Event_syscall, without a preceding Event_call *) Lemma asm_to_ir cpm (ge: genv) m_a0 @@ -586,6 +626,7 @@ Section PROOF. (* end case *) { end_case. } rename H0 into STAR. inv H; simpl. + - (** internal *) destruct (Genv.find_funct_ptr ge b') eqn:NEXTF. (* no next function *) @@ -600,16 +641,17 @@ Section PROOF. } unfold match_state in MTST. destruct ist as [[[cur m_i] ik] |]. 2:{ inv MTST. } - destruct MTST as (MTST0 & MTST1 & MTST2 & MTST3). destruct MTST3 as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5). + destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). destruct MTST3 as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5). exploit mem_delta_exec_instr. eapply MEM3. eapply H3. eapply MEM4. eapply MEM5. 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. + { 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. @@ -617,10 +659,12 @@ Section PROOF. split. auto. { unfold match_mem. repeat (split; auto). eapply public_not_freeable_exec_instr. 3: eapply H3. all: auto. eapply meminj_not_alloc_delta; eauto. } } - exploit IH. 4: eapply STAR. all: auto. eapply MTST'. + exploit IH. 4: eapply STAR. all: auto. eauto. + (* eapply MTST'. *) intros (btr & ist' & UNTR & ISTAR). exists btr, ist'. split; auto. } + (** has next function --- external *) { move STAR after NEXTF. inv STAR. (* end case *) @@ -632,7 +676,7 @@ Section PROOF. (** external & InternalCall *) rewrite NEXTPC in H10; inv H10. rewrite NEXTF in H11; inv H11. 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; eauto. intros FINDSYMB. + exploit Genv.invert_find_symbol; eauto. intros FINDSYMB. clear TEMP. (* reestablish meminj *) exploit mem_delta_apply_establish_inject. eapply MEM0. eapply MEM1. { admit. (* ez *) } @@ -657,7 +701,8 @@ Section PROOF. } { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } } - (* steps --- ReturnState *) + + (** steps --- ReturnState *) inv H. inv EV; simpl in *. (** return is nccc *) { rename H6 into STAR, H into NCCC. rewrite Pregmap.gss in H13, PC_RA, RESTORE_SP, NO_CROSS_PTR, NCCC. @@ -684,7 +729,7 @@ Section PROOF. - unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pregmap.gss in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. - unfold wf_regset in *. rewrite Pregmap.gss. rewrite NEXTF2. auto. } - { instantiate (1:=Some (cur, m2', ik)). simpl. split. + { instantiate (1:=Some (cur, m2', ik)). simpl. split; auto. split; auto. split. { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pregmap.gss in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } split. { unfold match_cur_regset in *. rewrite Pregmap.gss. simpl in *. unfold Genv.type_of_call in NCCC. des_ifs. @@ -719,6 +764,7 @@ Section PROOF. } { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } } + (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) (* take a step *) inv STEP. @@ -728,23 +774,136 @@ Section PROOF. rewrite Pregmap.gss in H8; inv H8. rewrite NEXTF2 in H9; inv H9. assert (STUCK: ((set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (Vptr b2 Ptrofs.zero) X1) = Vundef). { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } - rewrite STUCK in STAR. inv STAR. - (* end case *) + rewrite STUCK in STAR. + exploit Genv.find_funct_ptr_iff. intros (TEMP & _). specialize (TEMP NEXTF2). exploit wf_ge_block_to_id; eauto. intros (ef_id2 & INVSYMB2). + exploit Genv.invert_find_symbol. eapply INVSYMB2. intros FINDSYMB2. clear TEMP. + (* reestablish meminj *) + exploit mem_delta_apply_establish_inject. eapply MEMINJ'2. eapply INCRINJ. + { admit. (* ez *) } + { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. + pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. + } + { econstructor 1. } + { simpl; eauto. } + { admit. (* VISFO0, FIX - unknown or not *) } + simpl. intros (m3' & TEMPEQ & MEMINJ''). symmetry in TEMPEQ. inv TEMPEQ. + exploit external_call_mem_inject. + 2:{ eapply H10. } + 2:{ eapply MEMINJ''. } { admit. } + { instantiate (1:=args0). admit. } + intros (f'' & vres'' & m3' & EXTCALL'' & VALINJ'' & MEMINJ'3 & _ & _ & INCRINJ'' & _). + inv STAR. + (* end case *) + { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d'); Bundle_call t0 ef_id2 (vals_to_eventvals ge args0) (ef_sig ef0) (Some [])]). simpl. + eexists. split; auto. econstructor 2. 2: econstructor 2. 3: econstructor 1. 3,4: eauto. + - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. + { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. + rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. + unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. + } + { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } + - eapply ir_step_intra_call_external. 2: eapply FINDSYMB2. 2: eapply NEXTF2. 6: eapply EXTCALL''. all: eauto. + { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. + rewrite H1. setoid_rewrite ALLOWED. rewrite NEXTPC in REC_CURCOMP; simpl in *. rewrite REC_CURCOMP. + unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. rewrite <- Heq. unfold Genv.find_comp, Genv.find_funct. des_ifs. + unfold Genv.type_of_call. unfold comp_of at 1. simpl. rewrite Pos.eqb_refl; auto. + } + { admit. (* fix? VISFO0 --- maybe case analysis first on unknowns? *) } + } inv H; simpl in *. rewrite Pregmap.gss in *. inv H6. (* end case *) - { admit. } + { inv EV. + (* return is NCCC - silent *) + { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d'); Bundle_call t0 ef_id2 (vals_to_eventvals ge args0) (ef_sig ef0) (Some [])]). simpl. + eexists. split; auto. econstructor 2. 2: econstructor 2. 3: econstructor 1. 3,4: eauto. + - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. + { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. + rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. + unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. + } + { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } + - eapply ir_step_intra_call_external. 2: eapply FINDSYMB2. 2: eapply NEXTF2. 6: eapply EXTCALL''. all: eauto. + { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. + rewrite H1. setoid_rewrite ALLOWED. rewrite NEXTPC in REC_CURCOMP; simpl in *. rewrite REC_CURCOMP. + unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. rewrite <- Heq. unfold Genv.find_comp, Genv.find_funct. des_ifs. + unfold Genv.type_of_call. unfold comp_of at 1. simpl. rewrite Pos.eqb_refl; auto. + } + { admit. (* fix? VISFO0 --- maybe case analysis first on unknowns? *) } + } + (* 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 *. + replace (Genv.find_comp_ignore_offset ge Vundef) with default_compartment in STUPD0; auto. 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 --- by some hacky reason *) + clear - PC_RA0. exfalso. simpl in PC_RA0. des_ifs. + } + } (* stuck case *) inv H; simpl in *; rewrite Pregmap.gss in *; inv H11. } - (** return is ccc --- next is poped from the stack, which is internal, so done *) - simpl in *. rewrite Pregmap.gss in *. - + (** return is ccc --- next is poped from the stack, which is internal, so done *) + simpl in *. rewrite Pregmap.gss in *. rename H6 into STAR. + unfold Genv.type_of_call in H. des_ifs. clear H. unfold update_stack_return in STUPD. rewrite Pregmap.gss in *. + 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 *. destruct WFASM as [WFASM1 WFASM2]. + inv WFASM1. simpl in *. des_ifs. clear H8. inv MTST2. + exploit (IH _ _ _ _ _ _ _ _ STAR). lia. all: auto. + { simpl. split; auto. unfold wf_regset. rewrite Pregmap.gss. rewrite PC_RA. rewrite Heq0. auto. } + { instantiate (4:=f'). instantiate (3:=m'0). instantiate (2:=[]). instantiate (1:=Some (next, m2', ik_tl)). simpl. split. + { inv WFIR1. simpl in *. auto. } + split. + { inv WFIR1. auto. } + split; auto. split. + { unfold match_cur_regset. rewrite Pregmap.gss. rewrite COMP. rewrite PC_RA. auto. } + split; auto. split; auto. simpl. split; auto. split; auto. + { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. + pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. + } + split. + { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. pose proof (public_not_freeable_exec_instr _ _ _ _ _ _ _ _ MEM3 NALLOC H3) as NFREE. + pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC2. + clear - H12 NFREE NALLOC2. unfold public_not_freeable in *. intros. specialize (NFREE _ H). intros CC. apply NFREE; clear NFREE. + eapply external_call_max_perm; eauto. unfold Mem.valid_block. unfold meminj_not_alloc in NALLOC2. + unfold Plt. destruct (Pos.ltb_spec b (Mem.nextblock m')); auto. specialize (NALLOC2 _ H0). congruence. + } + split; auto. constructor. + } + intros (btr & ist' & UTR & ISTAR'). + (* FIX: case analysis on whether extcall is unknown or not *) + exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')] + ++ ((Bundle_return [Event_return (Genv.find_comp_ignore_offset ge (rs' X1)) (Genv.find_comp_ignore_offset ge (rs' PC)) res0] res0) :: btr)), ist'. + simpl. rewrite UTR. split; auto. + econstructor 2. 2: econstructor 2. 3: eapply ISTAR'. 3,4: auto. + - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. + { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. + rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. + unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. + } + { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } + - inv WFIR1. simpl in *. des_ifs. clear H8. unfold wf_ir_cur in WFIR0. des_ifs. clear WFIR0. + eapply ir_step_vr_return_internal. 6: eapply Heq1. all: eauto. + { intros. eapply NO_CROSS_PTR. + rewrite PC_RA, NEXTPC. simpl. rewrite <- COMP. rewrite MTST1 in H. + rewrite <- ALLOWED. rewrite H0 in H. simpl in H. unfold Genv.find_comp at 2 in H. unfold Genv.find_funct in H. des_ifs. + } + constructor; auto. + { rewrite COMP, MTST1. rewrite PC_RA, NEXTPC in *. simpl in *. rewrite H0. simpl. unfold Genv.find_comp at 2. unfold Genv.find_funct in *. des_ifs. + setoid_rewrite ALLOWED. unfold Genv.type_of_call. rewrite Pos.eqb_sym, Heq. auto. + } + { replace (funsig (Internal f3)) with sig3; auto. unfold match_cur_stack in MTST0. des_ifs. } + { rewrite COMP. rewrite PC_RA. simpl. rewrite NEXTPC. simpl. unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. + replace (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) with (Genv.find_comp ge (Vptr b Ptrofs.zero)); auto. + rewrite <- ALLOWED. unfold Genv.find_comp. unfold Genv.find_funct. des_ifs. + } + } - - (* TODO *) - + - (** internal_call *) + (* TODO *) + From 7b6e32bd84d03339c3aab0ebc9bfb96a0522f126 Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 26 Jul 2023 18:37:07 +0200 Subject: [PATCH 082/174] WIP --- security/BtInfoAsm.v | 625 ++++++++++++++++++++++++++++++------------- 1 file changed, 437 insertions(+), 188 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 32ccb87cbf..3255cd96cc 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -606,6 +606,225 @@ Section PROOF. 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_returnstate0 + 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 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 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). + (** step --- ReturnState *) + 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 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. split; auto. } + } + intros (btr & ist' & UTR & ISTAR'). + exists btr, ist'. split; auto. + } + + (* TODO *) + + (* (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) *) + (* (* take a step *) *) + (* inv STEP. *) + (* (* invalid *) *) + (* 1,2,3,4: rewrite Pregmap.gss in H8; inv H8; rewrite NEXTF2 in H9; inv H9. *) + (* (** external & InternalCall & next PC is Vundef *) *) + (* rewrite Pregmap.gss in H8; inv H8. rewrite NEXTF2 in H9; inv H9. *) + (* assert (STUCK: ((set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (Vptr b2 Ptrofs.zero) X1) = Vundef). *) + (* { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } *) + (* rewrite STUCK in STAR. *) + (* exploit Genv.find_funct_ptr_iff. intros (TEMP & _). specialize (TEMP NEXTF2). exploit wf_ge_block_to_id; eauto. intros (ef_id2 & INVSYMB2). *) + (* exploit Genv.invert_find_symbol. eapply INVSYMB2. intros FINDSYMB2. clear TEMP. *) + (* (* reestablish meminj *) *) + (* exploit mem_delta_apply_establish_inject. eapply MEMINJ'2. eapply INCRINJ. *) + (* { admit. (* ez *) } *) + (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. *) + (* pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. *) + (* } *) + (* { econstructor 1. } *) + (* { simpl; eauto. } *) + (* { admit. (* VISFO0, FIX - unknown or not *) } *) + (* simpl. intros (m3' & TEMPEQ & MEMINJ''). symmetry in TEMPEQ. inv TEMPEQ. *) + (* exploit external_call_mem_inject. *) + (* 2:{ eapply H10. } *) + (* 2:{ eapply MEMINJ''. } *) + (* { admit. } *) + (* { instantiate (1:=args0). admit. } *) + (* intros (f'' & vres'' & m3' & EXTCALL'' & VALINJ'' & MEMINJ'3 & _ & _ & INCRINJ'' & _). *) + (* inv STAR. *) + (* (* end case *) *) + (* { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d'); Bundle_call t0 ef_id2 (vals_to_eventvals ge args0) (ef_sig ef0) (Some [])]). simpl. *) + (* eexists. split; auto. econstructor 2. 2: econstructor 2. 3: econstructor 1. 3,4: eauto. *) + (* - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. *) + (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) + (* rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. *) + (* unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. *) + (* } *) + (* { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } *) + (* - eapply ir_step_intra_call_external. 2: eapply FINDSYMB2. 2: eapply NEXTF2. 6: eapply EXTCALL''. all: eauto. *) + (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) + (* rewrite H1. setoid_rewrite ALLOWED. rewrite NEXTPC in REC_CURCOMP; simpl in *. rewrite REC_CURCOMP. *) + (* unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. rewrite <- Heq. unfold Genv.find_comp, Genv.find_funct. des_ifs. *) + (* unfold Genv.type_of_call. unfold comp_of at 1. simpl. rewrite Pos.eqb_refl; auto. *) + (* } *) + (* { admit. (* fix? VISFO0 --- maybe case analysis first on unknowns? *) } *) + (* } *) + (* inv H; simpl in *. rewrite Pregmap.gss in *. inv H6. *) + (* (* end case *) *) + (* { inv EV. *) + (* (* return is NCCC - silent *) *) + (* { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d'); Bundle_call t0 ef_id2 (vals_to_eventvals ge args0) (ef_sig ef0) (Some [])]). simpl. *) + (* eexists. split; auto. econstructor 2. 2: econstructor 2. 3: econstructor 1. 3,4: eauto. *) + (* - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. *) + (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) + (* rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. *) + (* unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. *) + (* } *) + (* { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } *) + (* - eapply ir_step_intra_call_external. 2: eapply FINDSYMB2. 2: eapply NEXTF2. 6: eapply EXTCALL''. all: eauto. *) + (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) + (* rewrite H1. setoid_rewrite ALLOWED. rewrite NEXTPC in REC_CURCOMP; simpl in *. rewrite REC_CURCOMP. *) + (* unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. rewrite <- Heq. unfold Genv.find_comp, Genv.find_funct. des_ifs. *) + (* unfold Genv.type_of_call. unfold comp_of at 1. simpl. rewrite Pos.eqb_refl; auto. *) + (* } *) + (* { admit. (* fix? VISFO0 --- maybe case analysis first on unknowns? *) } *) + (* } *) + (* (* 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 *. *) + (* replace (Genv.find_comp_ignore_offset ge Vundef) with default_compartment in STUPD0; auto. 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 --- by some hacky reason *) *) + (* clear - PC_RA0. exfalso. simpl in PC_RA0. des_ifs. *) + (* } *) + (* } *) + (* (* stuck case *) *) + (* inv H; simpl in *; rewrite Pregmap.gss in *; inv H11. *) + (* } *) + + (* (** return is ccc --- next is poped from the stack, which is internal, so done *) *) + (* simpl in *. rewrite Pregmap.gss in *. rename H6 into STAR. *) + (* unfold Genv.type_of_call in H. des_ifs. clear H. unfold update_stack_return in STUPD. rewrite Pregmap.gss in *. *) + (* 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 *. destruct WFASM as [WFASM1 WFASM2]. *) + (* inv WFASM1. simpl in *. des_ifs. clear H8. inv MTST2. *) + (* exploit (IH _ _ _ _ _ _ _ _ STAR). lia. all: auto. *) + (* { simpl. split; auto. unfold wf_regset. rewrite Pregmap.gss. rewrite PC_RA. rewrite Heq0. auto. } *) + (* { instantiate (4:=f'). instantiate (3:=m'0). instantiate (2:=[]). instantiate (1:=Some (next, m2', ik_tl)). simpl. split. *) + (* { inv WFIR1. simpl in *. auto. } *) + (* split. *) + (* { inv WFIR1. auto. } *) + (* split; auto. split. *) + (* { unfold match_cur_regset. rewrite Pregmap.gss. rewrite COMP. rewrite PC_RA. auto. } *) + (* split; auto. split; auto. simpl. split; auto. split; auto. *) + (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. *) + (* pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. *) + (* } *) + (* split. *) + (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. pose proof (public_not_freeable_exec_instr _ _ _ _ _ _ _ _ MEM3 NALLOC H3) as NFREE. *) + (* pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC2. *) + (* clear - H12 NFREE NALLOC2. unfold public_not_freeable in *. intros. specialize (NFREE _ H). intros CC. apply NFREE; clear NFREE. *) + (* eapply external_call_max_perm; eauto. unfold Mem.valid_block. unfold meminj_not_alloc in NALLOC2. *) + (* unfold Plt. destruct (Pos.ltb_spec b (Mem.nextblock m')); auto. specialize (NALLOC2 _ H0). congruence. *) + (* } *) + (* split; auto. constructor. *) + (* } *) + (* intros (btr & ist' & UTR & ISTAR'). *) + (* (* FIX: case analysis on whether extcall is unknown or not *) *) + (* exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')] *) + (* ++ ((Bundle_return [Event_return (Genv.find_comp_ignore_offset ge (rs' X1)) (Genv.find_comp_ignore_offset ge (rs' PC)) res0] res0) :: btr)), ist'. *) + (* simpl. rewrite UTR. split; auto. *) + (* econstructor 2. 2: econstructor 2. 3: eapply ISTAR'. 3,4: auto. *) + (* - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. *) + (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) + (* rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. *) + (* unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. *) + (* } *) + (* { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } *) + (* - inv WFIR1. simpl in *. des_ifs. clear H8. unfold wf_ir_cur in WFIR0. des_ifs. clear WFIR0. *) + (* eapply ir_step_vr_return_internal. 6: eapply Heq1. all: eauto. *) + (* { intros. eapply NO_CROSS_PTR. *) + (* rewrite PC_RA, NEXTPC. simpl. rewrite <- COMP. rewrite MTST1 in H. *) + (* rewrite <- ALLOWED. rewrite H0 in H. simpl in H. unfold Genv.find_comp at 2 in H. unfold Genv.find_funct in H. des_ifs. *) + (* } *) + (* constructor; auto. *) + (* { rewrite COMP, MTST1. rewrite PC_RA, NEXTPC in *. simpl in *. rewrite H0. simpl. unfold Genv.find_comp at 2. unfold Genv.find_funct in *. des_ifs. *) + (* setoid_rewrite ALLOWED. unfold Genv.type_of_call. rewrite Pos.eqb_sym, Heq. auto. *) + (* } *) + (* { replace (funsig (Internal f3)) with sig3; auto. unfold match_cur_stack in MTST0. des_ifs. } *) + (* { rewrite COMP. rewrite PC_RA. simpl. rewrite NEXTPC. simpl. unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. *) + (* replace (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) with (Genv.find_comp ge (Vptr b Ptrofs.zero)); auto. *) + (* rewrite <- ALLOWED. unfold Genv.find_comp. unfold Genv.find_funct. des_ifs. *) + (* } *) + + Admitted. + (* If main is External, treat it as a different case - the trace can start with Event_syscall, without a preceding Event_call *) Lemma asm_to_ir @@ -659,11 +878,9 @@ Section PROOF. split. auto. { unfold match_mem. repeat (split; auto). eapply public_not_freeable_exec_instr. 3: eapply H3. all: auto. eapply meminj_not_alloc_delta; eauto. } } - exploit IH. 4: eapply STAR. all: auto. eauto. - (* eapply MTST'. *) - intros (btr & ist' & UNTR & ISTAR). - exists btr, ist'. split; auto. + exploit IH. 4: eapply STAR. 3: apply WFASM'. 3: eapply MTST'. all: auto. } + (*** Next = internal -> done *) (** has next function --- external *) { move STAR after NEXTF. inv STAR. @@ -691,7 +908,7 @@ Section PROOF. intros (f' & vres' & m2' & EXTCALL' & VALINJ' & MEMINJ'2 & _ & _ & INCRINJ & _). (* take a step *) rename H6 into STAR; move STAR after REC_CURCOMP. inv STAR. - (** terminates *) + (* end case *) { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')]). eexists. simpl. split; auto. econstructor 2. 2: econstructor 1. 2: auto. eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. @@ -702,163 +919,12 @@ Section PROOF. { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } } - (** steps --- ReturnState *) - inv H. inv EV; simpl in *. - (** return is nccc *) - { rename H6 into STAR, H into NCCC. rewrite Pregmap.gss in H13, PC_RA, RESTORE_SP, NO_CROSS_PTR, NCCC. - pose proof STAR as STAR0. inv STAR. - (* end case *) - { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')]). simpl. eexists. split; auto. - econstructor 2. 2: econstructor 1. 2: auto. - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. - { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. - rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. - unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. - } - { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } - } - (* has next step - if internal, done; if external, ub *) - rename H into STEP, H6 into STAR. destruct (rs' X1) eqn:NEXTPC2. - 1,2,3,4,5: inv STEP; rewrite Pregmap.gss in H8; inv H8. (* make a lemma *) - destruct (Genv.find_funct_ptr ge b1) eqn:NEXTF2. - 2:{ inv STEP; rewrite Pregmap.gss in H8; inv H8; rewrite NEXTF2 in H9; inv H9. (* make a lemma *) } - destruct f0. - (** next is internal *) - { exploit IH; clear IH. 4: eapply STAR0. lia. all: auto. - { simpl. destruct WFASM as [WFASM1 WFASM2]. split. - - unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pregmap.gss in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. - - unfold wf_regset in *. rewrite Pregmap.gss. rewrite NEXTF2. auto. - } - { instantiate (1:=Some (cur, m2', ik)). simpl. split; auto. split; auto. split. - { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pregmap.gss in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } - split. - { unfold match_cur_regset in *. rewrite Pregmap.gss. simpl in *. unfold Genv.type_of_call in NCCC. des_ifs. - rewrite MTST1. rewrite H0; simpl. apply Pos.eqb_eq in Heq. rewrite Heq. rewrite <- REC_CURCOMP. rewrite NEXTPC. simpl. rewrite <- ALLOWED. - unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite H1. auto. - } - split. - { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pregmap.gss in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } - { instantiate (3:=f'). instantiate (2:=[]). instantiate (1:=m'0). unfold match_mem. simpl. split; auto. split; auto. split. - { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. - pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. - } - split. - { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. pose proof (public_not_freeable_exec_instr _ _ _ _ _ _ _ _ MEM3 NALLOC H3) as NFREE. - pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC2. - clear - H12 NFREE NALLOC2. unfold public_not_freeable in *. intros. specialize (NFREE _ H). intros CC. apply NFREE; clear NFREE. - eapply external_call_max_perm; eauto. unfold Mem.valid_block. unfold meminj_not_alloc in NALLOC2. - unfold Plt. destruct (Pos.ltb_spec b (Mem.nextblock m')); auto. specialize (NALLOC2 _ H0). congruence. - } - split; auto. constructor. - } - } - intros (btr & ist' & UTR & ISTAR'). - (* FIX: case analysis on whether extcall is unknown or not *) - exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')] ++ btr), ist'. simpl. rewrite UTR. split; auto. - econstructor 2. 2: eapply ISTAR'. 2: auto. - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. - { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. - rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. - unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. - } - { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } - } - - (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) - (* take a step *) - inv STEP. - (* invalid *) - 1,2,3,4: rewrite Pregmap.gss in H8; inv H8; rewrite NEXTF2 in H9; inv H9. - (** external & InternalCall & next PC is Vundef *) - rewrite Pregmap.gss in H8; inv H8. rewrite NEXTF2 in H9; inv H9. - assert (STUCK: ((set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (Vptr b2 Ptrofs.zero) X1) = Vundef). - { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } - rewrite STUCK in STAR. - exploit Genv.find_funct_ptr_iff. intros (TEMP & _). specialize (TEMP NEXTF2). exploit wf_ge_block_to_id; eauto. intros (ef_id2 & INVSYMB2). - exploit Genv.invert_find_symbol. eapply INVSYMB2. intros FINDSYMB2. clear TEMP. - (* reestablish meminj *) - exploit mem_delta_apply_establish_inject. eapply MEMINJ'2. eapply INCRINJ. - { admit. (* ez *) } - { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. - pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. - } - { econstructor 1. } - { simpl; eauto. } - { admit. (* VISFO0, FIX - unknown or not *) } - simpl. intros (m3' & TEMPEQ & MEMINJ''). symmetry in TEMPEQ. inv TEMPEQ. - exploit external_call_mem_inject. - 2:{ eapply H10. } - 2:{ eapply MEMINJ''. } - { admit. } - { instantiate (1:=args0). admit. } - intros (f'' & vres'' & m3' & EXTCALL'' & VALINJ'' & MEMINJ'3 & _ & _ & INCRINJ'' & _). - inv STAR. - (* end case *) - { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d'); Bundle_call t0 ef_id2 (vals_to_eventvals ge args0) (ef_sig ef0) (Some [])]). simpl. - eexists. split; auto. econstructor 2. 2: econstructor 2. 3: econstructor 1. 3,4: eauto. - - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. - { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. - rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. - unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. - } - { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } - - eapply ir_step_intra_call_external. 2: eapply FINDSYMB2. 2: eapply NEXTF2. 6: eapply EXTCALL''. all: eauto. - { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. - rewrite H1. setoid_rewrite ALLOWED. rewrite NEXTPC in REC_CURCOMP; simpl in *. rewrite REC_CURCOMP. - unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. rewrite <- Heq. unfold Genv.find_comp, Genv.find_funct. des_ifs. - unfold Genv.type_of_call. unfold comp_of at 1. simpl. rewrite Pos.eqb_refl; auto. - } - { admit. (* fix? VISFO0 --- maybe case analysis first on unknowns? *) } - } - inv H; simpl in *. rewrite Pregmap.gss in *. inv H6. - (* end case *) - { inv EV. - (* return is NCCC - silent *) - { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d'); Bundle_call t0 ef_id2 (vals_to_eventvals ge args0) (ef_sig ef0) (Some [])]). simpl. - eexists. split; auto. econstructor 2. 2: econstructor 2. 3: econstructor 1. 3,4: eauto. - - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. - { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. - rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. - unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. - } - { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } - - eapply ir_step_intra_call_external. 2: eapply FINDSYMB2. 2: eapply NEXTF2. 6: eapply EXTCALL''. all: eauto. - { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. - rewrite H1. setoid_rewrite ALLOWED. rewrite NEXTPC in REC_CURCOMP; simpl in *. rewrite REC_CURCOMP. - unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. rewrite <- Heq. unfold Genv.find_comp, Genv.find_funct. des_ifs. - unfold Genv.type_of_call. unfold comp_of at 1. simpl. rewrite Pos.eqb_refl; auto. - } - { admit. (* fix? VISFO0 --- maybe case analysis first on unknowns? *) } - } - (* 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 *. - replace (Genv.find_comp_ignore_offset ge Vundef) with default_compartment in STUPD0; auto. 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 --- by some hacky reason *) - clear - PC_RA0. exfalso. simpl in PC_RA0. des_ifs. - } - } - (* stuck case *) - inv H; simpl in *; rewrite Pregmap.gss in *; inv H11. + destruct WFASM as [WFASM0 WFASM1]. + exploit asm_to_ir_returnstate0. 2: eapply IH. 11: eapply H. 11: eapply H6. all: auto. 1,2,3: eauto. all: auto. + { unfold match_cur_regset in *. simpl in *. rewrite <- REC_CURCOMP. rewrite NEXTPC. simpl. rewrite <- ALLOWED. + rewrite MTST1, H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite H1. auto. } - - (** return is ccc --- next is poped from the stack, which is internal, so done *) - simpl in *. rewrite Pregmap.gss in *. rename H6 into STAR. - unfold Genv.type_of_call in H. des_ifs. clear H. unfold update_stack_return in STUPD. rewrite Pregmap.gss in *. - 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 *. destruct WFASM as [WFASM1 WFASM2]. - inv WFASM1. simpl in *. des_ifs. clear H8. inv MTST2. - exploit (IH _ _ _ _ _ _ _ _ STAR). lia. all: auto. - { simpl. split; auto. unfold wf_regset. rewrite Pregmap.gss. rewrite PC_RA. rewrite Heq0. auto. } - { instantiate (4:=f'). instantiate (3:=m'0). instantiate (2:=[]). instantiate (1:=Some (next, m2', ik_tl)). simpl. split. - { inv WFIR1. simpl in *. auto. } - split. - { inv WFIR1. auto. } - split; auto. split. - { unfold match_cur_regset. rewrite Pregmap.gss. rewrite COMP. rewrite PC_RA. auto. } - split; auto. split; auto. simpl. split; auto. split; auto. + { instantiate (4:=f'). instantiate (3:=[]). instantiate (2:=m'0). instantiate (1:=m2'). unfold match_mem. simpl. split; auto. split; auto. split. { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. @@ -872,35 +938,218 @@ Section PROOF. } split; auto. constructor. } - intros (btr & ist' & UTR & ISTAR'). - (* FIX: case analysis on whether extcall is unknown or not *) - exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')] - ++ ((Bundle_return [Event_return (Genv.find_comp_ignore_offset ge (rs' X1)) (Genv.find_comp_ignore_offset ge (rs' PC)) res0] res0) :: btr)), ist'. - simpl. rewrite UTR. split; auto. - econstructor 2. 2: econstructor 2. 3: eapply ISTAR'. 3,4: auto. - - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. - { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. - rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. - unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. - } - { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } - - inv WFIR1. simpl in *. des_ifs. clear H8. unfold wf_ir_cur in WFIR0. des_ifs. clear WFIR0. - eapply ir_step_vr_return_internal. 6: eapply Heq1. all: eauto. - { intros. eapply NO_CROSS_PTR. - rewrite PC_RA, NEXTPC. simpl. rewrite <- COMP. rewrite MTST1 in H. - rewrite <- ALLOWED. rewrite H0 in H. simpl in H. unfold Genv.find_comp at 2 in H. unfold Genv.find_funct in H. des_ifs. - } - constructor; auto. - { rewrite COMP, MTST1. rewrite PC_RA, NEXTPC in *. simpl in *. rewrite H0. simpl. unfold Genv.find_comp at 2. unfold Genv.find_funct in *. des_ifs. - setoid_rewrite ALLOWED. unfold Genv.type_of_call. rewrite Pos.eqb_sym, Heq. auto. - } - { replace (funsig (Internal f3)) with sig3; auto. unfold match_cur_stack in MTST0. des_ifs. } - { rewrite COMP. rewrite PC_RA. simpl. rewrite NEXTPC. simpl. unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. - replace (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) with (Genv.find_comp ge (Vptr b Ptrofs.zero)); auto. - rewrite <- ALLOWED. unfold Genv.find_comp. unfold Genv.find_funct. des_ifs. - } + { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } + intros (btr & ist' & UTR & ISTAR). + exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')] ++ btr), ist'. simpl. rewrite UTR. split; auto. + econstructor 2. 2: eapply ISTAR. 2: auto. + eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. + { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. + rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. + unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. + } + { admit. (* FIX: at exists, if knowns, empty event, unknown case uses VISFO --- case analysis first on unknowns? *) } } + (*** lemma here *) + (* (** steps --- ReturnState *) *) + (* inv H. inv EV; simpl in *. *) + (* (** return is nccc *) *) + (* { rename H6 into STAR, H into NCCC. rewrite Pregmap.gss in H13, PC_RA, RESTORE_SP, NO_CROSS_PTR, NCCC. *) + (* pose proof STAR as STAR0. inv STAR. *) + (* (* end case *) *) + (* { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')]). simpl. eexists. split; auto. *) + (* econstructor 2. 2: econstructor 1. 2: auto. *) + (* eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. *) + (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) + (* rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. *) + (* unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. *) + (* } *) + (* { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } *) + (* } *) + (* (* has next step - if internal, done; if external, ub *) *) + (* rename H into STEP, H6 into STAR. destruct (rs' X1) eqn:NEXTPC2. *) + (* 1,2,3,4,5: inv STEP; rewrite Pregmap.gss in H8; inv H8. (* make a lemma *) *) + (* destruct (Genv.find_funct_ptr ge b1) eqn:NEXTF2. *) + (* 2:{ inv STEP; rewrite Pregmap.gss in H8; inv H8; rewrite NEXTF2 in H9; inv H9. (* make a lemma *) } *) + (* destruct f0. *) + (* (** next is internal *) *) + (* { exploit IH; clear IH. 4: eapply STAR0. lia. all: auto. *) + (* { simpl. destruct WFASM as [WFASM1 WFASM2]. split. *) + (* - unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pregmap.gss in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. *) + (* - unfold wf_regset in *. rewrite Pregmap.gss. rewrite NEXTF2. auto. *) + (* } *) + (* { instantiate (1:=Some (cur, m2', ik)). simpl. split; auto. split; auto. split. *) + (* { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pregmap.gss in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } *) + (* split. *) + (* { unfold match_cur_regset in *. rewrite Pregmap.gss. simpl in *. unfold Genv.type_of_call in NCCC. des_ifs. *) + (* rewrite MTST1. rewrite H0; simpl. apply Pos.eqb_eq in Heq. rewrite Heq. rewrite <- REC_CURCOMP. rewrite NEXTPC. simpl. rewrite <- ALLOWED. *) + (* unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite H1. auto. *) + (* } *) + (* split. *) + (* { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pregmap.gss in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } *) + (* { instantiate (3:=f'). instantiate (2:=[]). instantiate (1:=m'0). unfold match_mem. simpl. split; auto. split; auto. split. *) + (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. *) + (* pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. *) + (* } *) + (* split. *) + (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. pose proof (public_not_freeable_exec_instr _ _ _ _ _ _ _ _ MEM3 NALLOC H3) as NFREE. *) + (* pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC2. *) + (* clear - H12 NFREE NALLOC2. unfold public_not_freeable in *. intros. specialize (NFREE _ H). intros CC. apply NFREE; clear NFREE. *) + (* eapply external_call_max_perm; eauto. unfold Mem.valid_block. unfold meminj_not_alloc in NALLOC2. *) + (* unfold Plt. destruct (Pos.ltb_spec b (Mem.nextblock m')); auto. specialize (NALLOC2 _ H0). congruence. *) + (* } *) + (* split; auto. constructor. *) + (* } *) + (* } *) + (* intros (btr & ist' & UTR & ISTAR'). *) + (* (* FIX: case analysis on whether extcall is unknown or not *) *) + (* exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')] ++ btr), ist'. simpl. rewrite UTR. split; auto. *) + (* econstructor 2. 2: eapply ISTAR'. 2: auto. *) + (* eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. *) + (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) + (* rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. *) + (* unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. *) + (* } *) + (* { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } *) + (* } *) + + (* (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) *) + (* (* take a step *) *) + (* inv STEP. *) + (* (* invalid *) *) + (* 1,2,3,4: rewrite Pregmap.gss in H8; inv H8; rewrite NEXTF2 in H9; inv H9. *) + (* (** external & InternalCall & next PC is Vundef *) *) + (* rewrite Pregmap.gss in H8; inv H8. rewrite NEXTF2 in H9; inv H9. *) + (* assert (STUCK: ((set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (Vptr b2 Ptrofs.zero) X1) = Vundef). *) + (* { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } *) + (* rewrite STUCK in STAR. *) + (* exploit Genv.find_funct_ptr_iff. intros (TEMP & _). specialize (TEMP NEXTF2). exploit wf_ge_block_to_id; eauto. intros (ef_id2 & INVSYMB2). *) + (* exploit Genv.invert_find_symbol. eapply INVSYMB2. intros FINDSYMB2. clear TEMP. *) + (* (* reestablish meminj *) *) + (* exploit mem_delta_apply_establish_inject. eapply MEMINJ'2. eapply INCRINJ. *) + (* { admit. (* ez *) } *) + (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. *) + (* pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. *) + (* } *) + (* { econstructor 1. } *) + (* { simpl; eauto. } *) + (* { admit. (* VISFO0, FIX - unknown or not *) } *) + (* simpl. intros (m3' & TEMPEQ & MEMINJ''). symmetry in TEMPEQ. inv TEMPEQ. *) + (* exploit external_call_mem_inject. *) + (* 2:{ eapply H10. } *) + (* 2:{ eapply MEMINJ''. } *) + (* { admit. } *) + (* { instantiate (1:=args0). admit. } *) + (* intros (f'' & vres'' & m3' & EXTCALL'' & VALINJ'' & MEMINJ'3 & _ & _ & INCRINJ'' & _). *) + (* inv STAR. *) + (* (* end case *) *) + (* { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d'); Bundle_call t0 ef_id2 (vals_to_eventvals ge args0) (ef_sig ef0) (Some [])]). simpl. *) + (* eexists. split; auto. econstructor 2. 2: econstructor 2. 3: econstructor 1. 3,4: eauto. *) + (* - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. *) + (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) + (* rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. *) + (* unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. *) + (* } *) + (* { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } *) + (* - eapply ir_step_intra_call_external. 2: eapply FINDSYMB2. 2: eapply NEXTF2. 6: eapply EXTCALL''. all: eauto. *) + (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) + (* rewrite H1. setoid_rewrite ALLOWED. rewrite NEXTPC in REC_CURCOMP; simpl in *. rewrite REC_CURCOMP. *) + (* unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. rewrite <- Heq. unfold Genv.find_comp, Genv.find_funct. des_ifs. *) + (* unfold Genv.type_of_call. unfold comp_of at 1. simpl. rewrite Pos.eqb_refl; auto. *) + (* } *) + (* { admit. (* fix? VISFO0 --- maybe case analysis first on unknowns? *) } *) + (* } *) + (* inv H; simpl in *. rewrite Pregmap.gss in *. inv H6. *) + (* (* end case *) *) + (* { inv EV. *) + (* (* return is NCCC - silent *) *) + (* { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d'); Bundle_call t0 ef_id2 (vals_to_eventvals ge args0) (ef_sig ef0) (Some [])]). simpl. *) + (* eexists. split; auto. econstructor 2. 2: econstructor 2. 3: econstructor 1. 3,4: eauto. *) + (* - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. *) + (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) + (* rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. *) + (* unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. *) + (* } *) + (* { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } *) + (* - eapply ir_step_intra_call_external. 2: eapply FINDSYMB2. 2: eapply NEXTF2. 6: eapply EXTCALL''. all: eauto. *) + (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) + (* rewrite H1. setoid_rewrite ALLOWED. rewrite NEXTPC in REC_CURCOMP; simpl in *. rewrite REC_CURCOMP. *) + (* unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. rewrite <- Heq. unfold Genv.find_comp, Genv.find_funct. des_ifs. *) + (* unfold Genv.type_of_call. unfold comp_of at 1. simpl. rewrite Pos.eqb_refl; auto. *) + (* } *) + (* { admit. (* fix? VISFO0 --- maybe case analysis first on unknowns? *) } *) + (* } *) + (* (* 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 *. *) + (* replace (Genv.find_comp_ignore_offset ge Vundef) with default_compartment in STUPD0; auto. 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 --- by some hacky reason *) *) + (* clear - PC_RA0. exfalso. simpl in PC_RA0. des_ifs. *) + (* } *) + (* } *) + (* (* stuck case *) *) + (* inv H; simpl in *; rewrite Pregmap.gss in *; inv H11. *) + (* } *) + + (* (** return is ccc --- next is poped from the stack, which is internal, so done *) *) + (* simpl in *. rewrite Pregmap.gss in *. rename H6 into STAR. *) + (* unfold Genv.type_of_call in H. des_ifs. clear H. unfold update_stack_return in STUPD. rewrite Pregmap.gss in *. *) + (* 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 *. destruct WFASM as [WFASM1 WFASM2]. *) + (* inv WFASM1. simpl in *. des_ifs. clear H8. inv MTST2. *) + (* exploit (IH _ _ _ _ _ _ _ _ STAR). lia. all: auto. *) + (* { simpl. split; auto. unfold wf_regset. rewrite Pregmap.gss. rewrite PC_RA. rewrite Heq0. auto. } *) + (* { instantiate (4:=f'). instantiate (3:=m'0). instantiate (2:=[]). instantiate (1:=Some (next, m2', ik_tl)). simpl. split. *) + (* { inv WFIR1. simpl in *. auto. } *) + (* split. *) + (* { inv WFIR1. auto. } *) + (* split; auto. split. *) + (* { unfold match_cur_regset. rewrite Pregmap.gss. rewrite COMP. rewrite PC_RA. auto. } *) + (* split; auto. split; auto. simpl. split; auto. split; auto. *) + (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. *) + (* pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. *) + (* } *) + (* split. *) + (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. pose proof (public_not_freeable_exec_instr _ _ _ _ _ _ _ _ MEM3 NALLOC H3) as NFREE. *) + (* pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC2. *) + (* clear - H12 NFREE NALLOC2. unfold public_not_freeable in *. intros. specialize (NFREE _ H). intros CC. apply NFREE; clear NFREE. *) + (* eapply external_call_max_perm; eauto. unfold Mem.valid_block. unfold meminj_not_alloc in NALLOC2. *) + (* unfold Plt. destruct (Pos.ltb_spec b (Mem.nextblock m')); auto. specialize (NALLOC2 _ H0). congruence. *) + (* } *) + (* split; auto. constructor. *) + (* } *) + (* intros (btr & ist' & UTR & ISTAR'). *) + (* (* FIX: case analysis on whether extcall is unknown or not *) *) + (* exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')] *) + (* ++ ((Bundle_return [Event_return (Genv.find_comp_ignore_offset ge (rs' X1)) (Genv.find_comp_ignore_offset ge (rs' PC)) res0] res0) :: btr)), ist'. *) + (* simpl. rewrite UTR. split; auto. *) + (* econstructor 2. 2: econstructor 2. 3: eapply ISTAR'. 3,4: auto. *) + (* - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. *) + (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) + (* rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. *) + (* unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. *) + (* } *) + (* { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } *) + (* - inv WFIR1. simpl in *. des_ifs. clear H8. unfold wf_ir_cur in WFIR0. des_ifs. clear WFIR0. *) + (* eapply ir_step_vr_return_internal. 6: eapply Heq1. all: eauto. *) + (* { intros. eapply NO_CROSS_PTR. *) + (* rewrite PC_RA, NEXTPC. simpl. rewrite <- COMP. rewrite MTST1 in H. *) + (* rewrite <- ALLOWED. rewrite H0 in H. simpl in H. unfold Genv.find_comp at 2 in H. unfold Genv.find_funct in H. des_ifs. *) + (* } *) + (* constructor; auto. *) + (* { rewrite COMP, MTST1. rewrite PC_RA, NEXTPC in *. simpl in *. rewrite H0. simpl. unfold Genv.find_comp at 2. unfold Genv.find_funct in *. des_ifs. *) + (* setoid_rewrite ALLOWED. unfold Genv.type_of_call. rewrite Pos.eqb_sym, Heq. auto. *) + (* } *) + (* { replace (funsig (Internal f3)) with sig3; auto. unfold match_cur_stack in MTST0. des_ifs. } *) + (* { rewrite COMP. rewrite PC_RA. simpl. rewrite NEXTPC. simpl. unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. *) + (* replace (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) with (Genv.find_comp ge (Vptr b Ptrofs.zero)); auto. *) + (* rewrite <- ALLOWED. unfold Genv.find_comp. unfold Genv.find_funct. des_ifs. *) + (* } *) + (* } *) + - (** internal_call *) (* TODO *) From 94a555e4e3d6b3a215b2296a55f2165b6d7fdb62 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 27 Jul 2023 19:52:01 +0200 Subject: [PATCH 083/174] WIP --- security/BtInfoAsm.v | 741 ++++++++++++++++++++++++++++++++++--------- 1 file changed, 592 insertions(+), 149 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 3255cd96cc..8cd1125149 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -56,11 +56,46 @@ Section BUNDLE. | 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 -> 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 : bundle_event) (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 -> bundle_event -> 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. @@ -623,8 +658,275 @@ Section PROOF. 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 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 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 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). + (** 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. split; auto. } + } + intros (btr & ist' & UTR & ISTAR'). + exists btr, ist'. split; auto. + Qed. + + Definition extcall_known (ef: external_function) (ge: Senv.t) args := + match ef with + | EF_builtin _ name sg | EF_runtime _ name sg => + match Builtins.lookup_builtin_function name sg with + | Some _ => True + | None => False + end + | EF_memcpy _ _ _ => EF_memcpy_dest_not_pub ge args + | EF_external _ _ sg | EF_inline_asm _ _ sg _ => False + | _ => True + end. + + Lemma extcall_cases + ef ge m args + (VIS: visible_fo_if_unknown ef ge m args) + : + (visible_fo_and_unknown ef ge m args) \/ (extcall_known ef ge args). + Proof. destruct ef; simpl in *; auto. des_ifs; auto. des_ifs; auto. Qed. + + Lemma asm_to_ir_step_nccc_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 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 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)) + (* STEP : step_fix cpm ge (State st rs m_a) t1 s2 *) + 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 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). + (* 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. + apply extcall_cases in VISFO. destruct VISFO as [VISFO | KNOWN]. + + - (* extcall is unknown *) + (* reestablish meminj *) + exploit mem_delta_apply_establish_inject; eauto. + { admit. (* ez *) } + { admit. (* VISFO *) } + intros (m_i' & APPD' & MEMINJ'). exploit external_call_mem_inject; eauto. + { admit. (* ez *) } + { instantiate (1:=args). admit. } + intros (f' & vres' & m_i'' & EXTCALL' & VALINJ' & MEMINJ'' & _ & _ & INCRINJ' & _). + assert (MM': match_mem ge f' [] m' m_i'' m'). + { unfold match_mem. simpl. split; auto. split; auto. split. + { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. + clear - H4 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. + pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H4). + destruct (Pos.leb_spec (Mem.nextblock m_a) b); auto. + unfold Mem.valid_block in H0. apply H0 in H1. exfalso. unfold Plt in H1. lia. + } + split. + { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. + clear - H4 MEM3 NALLOC. unfold public_not_freeable in *. intros. + specialize (MEM3 _ H). intros CC. apply MEM3; 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_a)); auto. + specialize (NALLOC _ H0). congruence. + } + split; auto. constructor. + } + exists ([Bundle_call t ef_id (vals_to_eventvals ge args) (ef_sig ef0) (Some d)]). + do 5 eexists. splits; simpl. 3: eapply MM'. 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. + } + { clear - VISFO MEMINJ'. admit. (* TODO *) }. + + - (* extcall is known *) + (* TODO *) + + Admitted. + + 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 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 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). + (** 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_nccc_external. + 12: eapply STAR. 11: eapply NEXTF. 10: eapply NEXTPC. 9: eapply STEP. + all: eauto. + { split; 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_returnstate0 + Lemma asm_to_ir_returnstate_undef_ccc_external cpm (ge: genv) n n0 (LT: (n0 < n)%nat) (IH: forall y : nat, @@ -652,12 +954,166 @@ Section PROOF. (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) + 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). (** step --- ReturnState *) inv STEP. inv EV; simpl in *. + { rewrite CCC in H. congruence with H. } + clear H. + (* TODO *) + (** return is ccc --- next is poped from the stack, which is internal, so done *) + simpl in *. rewrite Pregmap.gss in *. rename H6 into STAR. + unfold Genv.type_of_call in H. des_ifs. clear H. unfold update_stack_return in STUPD. rewrite Pregmap.gss in *. + 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 *. destruct WFASM as [WFASM1 WFASM2]. + inv WFASM1. simpl in *. des_ifs. clear H8. inv MTST2. + exploit (IH _ _ _ _ _ _ _ _ STAR). lia. all: auto. + { simpl. split; auto. unfold wf_regset. rewrite Pregmap.gss. rewrite PC_RA. rewrite Heq0. auto. } + { instantiate (4:=f'). instantiate (3:=m'0). instantiate (2:=[]). instantiate (1:=Some (next, m2', ik_tl)). simpl. split. + { inv WFIR1. simpl in *. auto. } + split. + { inv WFIR1. auto. } + split; auto. split. + { unfold match_cur_regset. rewrite Pregmap.gss. rewrite COMP. rewrite PC_RA. auto. } + split; auto. split; auto. simpl. split; auto. split; auto. + { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. + pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. + } + split. + { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. pose proof (public_not_freeable_exec_instr _ _ _ _ _ _ _ _ MEM3 NALLOC H3) as NFREE. + pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC2. + clear - H12 NFREE NALLOC2. unfold public_not_freeable in *. intros. specialize (NFREE _ H). intros CC. apply NFREE; clear NFREE. + eapply external_call_max_perm; eauto. unfold Mem.valid_block. unfold meminj_not_alloc in NALLOC2. + unfold Plt. destruct (Pos.ltb_spec b (Mem.nextblock m')); auto. specialize (NALLOC2 _ H0). congruence. + } + split; auto. constructor. + } + intros (btr & ist' & UTR & ISTAR'). + (* FIX: case analysis on whether extcall is unknown or not *) + exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')] + ++ ((Bundle_return [Event_return (Genv.find_comp_ignore_offset ge (rs' X1)) (Genv.find_comp_ignore_offset ge (rs' PC)) res0] res0) :: btr)), ist'. + simpl. rewrite UTR. split; auto. + econstructor 2. 2: econstructor 2. 3: eapply ISTAR'. 3,4: auto. + - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. + { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. + rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. + unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. + } + { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } + - inv WFIR1. simpl in *. des_ifs. clear H8. unfold wf_ir_cur in WFIR0. des_ifs. clear WFIR0. + eapply ir_step_vr_return_internal. 6: eapply Heq1. all: eauto. + { intros. eapply NO_CROSS_PTR. + rewrite PC_RA, NEXTPC. simpl. rewrite <- COMP. rewrite MTST1 in H. + rewrite <- ALLOWED. rewrite H0 in H. simpl in H. unfold Genv.find_comp at 2 in H. unfold Genv.find_funct in H. des_ifs. + } + constructor; auto. + { rewrite COMP, MTST1. rewrite PC_RA, NEXTPC in *. simpl in *. rewrite H0. simpl. unfold Genv.find_comp at 2. unfold Genv.find_funct in *. des_ifs. + setoid_rewrite ALLOWED. unfold Genv.type_of_call. rewrite Pos.eqb_sym, Heq. auto. + } + { replace (funsig (Internal f3)) with sig3; auto. unfold match_cur_stack in MTST0. des_ifs. } + { rewrite COMP. rewrite PC_RA. simpl. rewrite NEXTPC. simpl. unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. + replace (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) with (Genv.find_comp ge (Vptr b Ptrofs.zero)); auto. + rewrite <- ALLOWED. unfold Genv.find_comp. unfold Genv.find_funct. des_ifs. + } + + + + + + (* garbage *) + move STEP after STAR. inv STEP. + (* invalid *) + 1,2,3,4: rewrite NEXTPC in H2; inv H2; rewrite NEXTF in H3; inv H3. + (** external & InternalCall & next PC is Vundef *) + rewrite NEXTPC in H2; inv H2; rewrite NEXTF in H3; inv H3. + + + clear args H5 H8 VISFO. + assert (STUCK: (set_pair (loc_external_result (ef_sig ef0)) res (undef_caller_save_regs rs)) + # PC <- (rs X1) PC = Vundef). + { rewrite Pregmap.gss. auto. } + (* 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. *) + + (* (* reestablish meminj *) *) + (* exploit mem_delta_apply_establish_inject. eapply MEMINJ'2. eapply INCRINJ. *) + (* { admit. (* ez *) } *) + (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. *) + (* pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. *) + (* } *) + (* { econstructor 1. } *) + (* { simpl; eauto. } *) + (* { admit. (* VISFO0, FIX - unknown or not *) } *) + (* simpl. intros (m3' & TEMPEQ & MEMINJ''). symmetry in TEMPEQ. inv TEMPEQ. *) + (* exploit external_call_mem_inject. *) + (* 2:{ eapply H10. } *) + (* 2:{ eapply MEMINJ''. } *) + (* { admit. } *) + (* { instantiate (1:=args0). admit. } *) + (* intros (f'' & vres'' & m3' & EXTCALL'' & VALINJ'' & MEMINJ'3 & _ & _ & INCRINJ'' & _). *) + + exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d'); Bundle_call t0 ef_id2 (vals_to_eventvals ge args0) (ef_sig ef0) (Some [])]). simpl. + eexists. split; auto. econstructor 2. 2: econstructor 2. 3: econstructor 1. 3,4: eauto. + - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. + { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. + rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. + unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. + } + { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } + - eapply ir_step_intra_call_external. 2: eapply FINDSYMB2. 2: eapply NEXTF2. 6: eapply EXTCALL''. all: eauto. + { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. + rewrite H1. setoid_rewrite ALLOWED. rewrite NEXTPC in REC_CURCOMP; simpl in *. rewrite REC_CURCOMP. + unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. rewrite <- Heq. unfold Genv.find_comp, Genv.find_funct. des_ifs. + unfold Genv.type_of_call. unfold comp_of at 1. simpl. rewrite Pos.eqb_refl; auto. + } + { admit. (* fix? VISFO0 --- maybe case analysis first on unknowns? *) } + } + + + 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 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 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). + (** 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. @@ -669,159 +1125,146 @@ Section PROOF. destruct fd. (** 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. split; auto. } - } - intros (btr & ist' & UTR & ISTAR'). - exists btr, ist'. split; auto. + { exploit asm_to_ir_returnstate_nccc_internal. 2: eapply IH. + 11: eapply STAR0. 10: eapply STEP0. all: eauto. split; eauto. } (* TODO *) - (* (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) *) - (* (* take a step *) *) - (* inv STEP. *) - (* (* invalid *) *) - (* 1,2,3,4: rewrite Pregmap.gss in H8; inv H8; rewrite NEXTF2 in H9; inv H9. *) - (* (** external & InternalCall & next PC is Vundef *) *) - (* rewrite Pregmap.gss in H8; inv H8. rewrite NEXTF2 in H9; inv H9. *) - (* assert (STUCK: ((set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (Vptr b2 Ptrofs.zero) X1) = Vundef). *) - (* { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } *) - (* rewrite STUCK in STAR. *) - (* exploit Genv.find_funct_ptr_iff. intros (TEMP & _). specialize (TEMP NEXTF2). exploit wf_ge_block_to_id; eauto. intros (ef_id2 & INVSYMB2). *) - (* exploit Genv.invert_find_symbol. eapply INVSYMB2. intros FINDSYMB2. clear TEMP. *) - (* (* reestablish meminj *) *) - (* exploit mem_delta_apply_establish_inject. eapply MEMINJ'2. eapply INCRINJ. *) - (* { admit. (* ez *) } *) - (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. *) - (* pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. *) - (* } *) - (* { econstructor 1. } *) - (* { simpl; eauto. } *) - (* { admit. (* VISFO0, FIX - unknown or not *) } *) - (* simpl. intros (m3' & TEMPEQ & MEMINJ''). symmetry in TEMPEQ. inv TEMPEQ. *) - (* exploit external_call_mem_inject. *) - (* 2:{ eapply H10. } *) - (* 2:{ eapply MEMINJ''. } *) - (* { admit. } *) - (* { instantiate (1:=args0). admit. } *) - (* intros (f'' & vres'' & m3' & EXTCALL'' & VALINJ'' & MEMINJ'3 & _ & _ & INCRINJ'' & _). *) - (* inv STAR. *) - (* (* end case *) *) - (* { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d'); Bundle_call t0 ef_id2 (vals_to_eventvals ge args0) (ef_sig ef0) (Some [])]). simpl. *) - (* eexists. split; auto. econstructor 2. 2: econstructor 2. 3: econstructor 1. 3,4: eauto. *) - (* - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. *) - (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) - (* rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. *) - (* unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. *) - (* } *) - (* { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } *) - (* - eapply ir_step_intra_call_external. 2: eapply FINDSYMB2. 2: eapply NEXTF2. 6: eapply EXTCALL''. all: eauto. *) - (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) - (* rewrite H1. setoid_rewrite ALLOWED. rewrite NEXTPC in REC_CURCOMP; simpl in *. rewrite REC_CURCOMP. *) - (* unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. rewrite <- Heq. unfold Genv.find_comp, Genv.find_funct. des_ifs. *) - (* unfold Genv.type_of_call. unfold comp_of at 1. simpl. rewrite Pos.eqb_refl; auto. *) - (* } *) - (* { admit. (* fix? VISFO0 --- maybe case analysis first on unknowns? *) } *) - (* } *) - (* inv H; simpl in *. rewrite Pregmap.gss in *. inv H6. *) - (* (* end case *) *) - (* { inv EV. *) - (* (* return is NCCC - silent *) *) - (* { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d'); Bundle_call t0 ef_id2 (vals_to_eventvals ge args0) (ef_sig ef0) (Some [])]). simpl. *) - (* eexists. split; auto. econstructor 2. 2: econstructor 2. 3: econstructor 1. 3,4: eauto. *) - (* - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. *) - (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) - (* rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. *) - (* unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. *) - (* } *) - (* { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } *) - (* - eapply ir_step_intra_call_external. 2: eapply FINDSYMB2. 2: eapply NEXTF2. 6: eapply EXTCALL''. all: eauto. *) - (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) - (* rewrite H1. setoid_rewrite ALLOWED. rewrite NEXTPC in REC_CURCOMP; simpl in *. rewrite REC_CURCOMP. *) - (* unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. rewrite <- Heq. unfold Genv.find_comp, Genv.find_funct. des_ifs. *) - (* unfold Genv.type_of_call. unfold comp_of at 1. simpl. rewrite Pos.eqb_refl; auto. *) - (* } *) - (* { admit. (* fix? VISFO0 --- maybe case analysis first on unknowns? *) } *) - (* } *) - (* (* 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 *. *) - (* replace (Genv.find_comp_ignore_offset ge Vundef) with default_compartment in STUPD0; auto. 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 --- by some hacky reason *) *) - (* clear - PC_RA0. exfalso. simpl in PC_RA0. des_ifs. *) - (* } *) - (* } *) - (* (* stuck case *) *) - (* inv H; simpl in *; rewrite Pregmap.gss in *; inv H11. *) - (* } *) + (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) + (* take a step *) + inv STEP. + (* invalid *) + 1,2,3,4: rewrite Pregmap.gss in H8; inv H8; rewrite NEXTF2 in H9; inv H9. + (** external & InternalCall & next PC is Vundef *) + rewrite Pregmap.gss in H8; inv H8. rewrite NEXTF2 in H9; inv H9. + assert (STUCK: ((set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (Vptr b2 Ptrofs.zero) X1) = Vundef). + { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } + rewrite STUCK in STAR. + exploit Genv.find_funct_ptr_iff. intros (TEMP & _). specialize (TEMP NEXTF2). exploit wf_ge_block_to_id; eauto. intros (ef_id2 & INVSYMB2). + exploit Genv.invert_find_symbol. eapply INVSYMB2. intros FINDSYMB2. clear TEMP. + (* reestablish meminj *) + exploit mem_delta_apply_establish_inject. eapply MEMINJ'2. eapply INCRINJ. + { admit. (* ez *) } + { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. + pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. + } + { econstructor 1. } + { simpl; eauto. } + { admit. (* VISFO0, FIX - unknown or not *) } + simpl. intros (m3' & TEMPEQ & MEMINJ''). symmetry in TEMPEQ. inv TEMPEQ. + exploit external_call_mem_inject. + 2:{ eapply H10. } + 2:{ eapply MEMINJ''. } + { admit. } + { instantiate (1:=args0). admit. } + intros (f'' & vres'' & m3' & EXTCALL'' & VALINJ'' & MEMINJ'3 & _ & _ & INCRINJ'' & _). + inv STAR. + (* end case *) + { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d'); Bundle_call t0 ef_id2 (vals_to_eventvals ge args0) (ef_sig ef0) (Some [])]). simpl. + eexists. split; auto. econstructor 2. 2: econstructor 2. 3: econstructor 1. 3,4: eauto. + - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. + { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. + rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. + unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. + } + { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } + - eapply ir_step_intra_call_external. 2: eapply FINDSYMB2. 2: eapply NEXTF2. 6: eapply EXTCALL''. all: eauto. + { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. + rewrite H1. setoid_rewrite ALLOWED. rewrite NEXTPC in REC_CURCOMP; simpl in *. rewrite REC_CURCOMP. + unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. rewrite <- Heq. unfold Genv.find_comp, Genv.find_funct. des_ifs. + unfold Genv.type_of_call. unfold comp_of at 1. simpl. rewrite Pos.eqb_refl; auto. + } + { admit. (* fix? VISFO0 --- maybe case analysis first on unknowns? *) } + } + inv H; simpl in *. rewrite Pregmap.gss in *. inv H6. + (* end case *) + { inv EV. + (* return is NCCC - silent *) + { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d'); Bundle_call t0 ef_id2 (vals_to_eventvals ge args0) (ef_sig ef0) (Some [])]). simpl. + eexists. split; auto. econstructor 2. 2: econstructor 2. 3: econstructor 1. 3,4: eauto. + - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. + { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. + rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. + unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. + } + { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } + - eapply ir_step_intra_call_external. 2: eapply FINDSYMB2. 2: eapply NEXTF2. 6: eapply EXTCALL''. all: eauto. + { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. + rewrite H1. setoid_rewrite ALLOWED. rewrite NEXTPC in REC_CURCOMP; simpl in *. rewrite REC_CURCOMP. + unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. rewrite <- Heq. unfold Genv.find_comp, Genv.find_funct. des_ifs. + unfold Genv.type_of_call. unfold comp_of at 1. simpl. rewrite Pos.eqb_refl; auto. + } + { admit. (* fix? VISFO0 --- maybe case analysis first on unknowns? *) } + } + (* 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 *. + replace (Genv.find_comp_ignore_offset ge Vundef) with default_compartment in STUPD0; auto. 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 --- by some hacky reason *) + clear - PC_RA0. exfalso. simpl in PC_RA0. des_ifs. + } + } + (* stuck case *) + inv H; simpl in *; rewrite Pregmap.gss in *; inv H11. + } - (* (** return is ccc --- next is poped from the stack, which is internal, so done *) *) - (* simpl in *. rewrite Pregmap.gss in *. rename H6 into STAR. *) - (* unfold Genv.type_of_call in H. des_ifs. clear H. unfold update_stack_return in STUPD. rewrite Pregmap.gss in *. *) - (* 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 *. destruct WFASM as [WFASM1 WFASM2]. *) - (* inv WFASM1. simpl in *. des_ifs. clear H8. inv MTST2. *) - (* exploit (IH _ _ _ _ _ _ _ _ STAR). lia. all: auto. *) - (* { simpl. split; auto. unfold wf_regset. rewrite Pregmap.gss. rewrite PC_RA. rewrite Heq0. auto. } *) - (* { instantiate (4:=f'). instantiate (3:=m'0). instantiate (2:=[]). instantiate (1:=Some (next, m2', ik_tl)). simpl. split. *) - (* { inv WFIR1. simpl in *. auto. } *) - (* split. *) - (* { inv WFIR1. auto. } *) - (* split; auto. split. *) - (* { unfold match_cur_regset. rewrite Pregmap.gss. rewrite COMP. rewrite PC_RA. auto. } *) - (* split; auto. split; auto. simpl. split; auto. split; auto. *) - (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. *) - (* pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. *) - (* } *) - (* split. *) - (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. pose proof (public_not_freeable_exec_instr _ _ _ _ _ _ _ _ MEM3 NALLOC H3) as NFREE. *) - (* pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC2. *) - (* clear - H12 NFREE NALLOC2. unfold public_not_freeable in *. intros. specialize (NFREE _ H). intros CC. apply NFREE; clear NFREE. *) - (* eapply external_call_max_perm; eauto. unfold Mem.valid_block. unfold meminj_not_alloc in NALLOC2. *) - (* unfold Plt. destruct (Pos.ltb_spec b (Mem.nextblock m')); auto. specialize (NALLOC2 _ H0). congruence. *) - (* } *) - (* split; auto. constructor. *) - (* } *) - (* intros (btr & ist' & UTR & ISTAR'). *) - (* (* FIX: case analysis on whether extcall is unknown or not *) *) - (* exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')] *) - (* ++ ((Bundle_return [Event_return (Genv.find_comp_ignore_offset ge (rs' X1)) (Genv.find_comp_ignore_offset ge (rs' PC)) res0] res0) :: btr)), ist'. *) - (* simpl. rewrite UTR. split; auto. *) - (* econstructor 2. 2: econstructor 2. 3: eapply ISTAR'. 3,4: auto. *) - (* - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. *) - (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) - (* rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. *) - (* unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. *) - (* } *) - (* { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } *) - (* - inv WFIR1. simpl in *. des_ifs. clear H8. unfold wf_ir_cur in WFIR0. des_ifs. clear WFIR0. *) - (* eapply ir_step_vr_return_internal. 6: eapply Heq1. all: eauto. *) - (* { intros. eapply NO_CROSS_PTR. *) - (* rewrite PC_RA, NEXTPC. simpl. rewrite <- COMP. rewrite MTST1 in H. *) - (* rewrite <- ALLOWED. rewrite H0 in H. simpl in H. unfold Genv.find_comp at 2 in H. unfold Genv.find_funct in H. des_ifs. *) - (* } *) - (* constructor; auto. *) - (* { rewrite COMP, MTST1. rewrite PC_RA, NEXTPC in *. simpl in *. rewrite H0. simpl. unfold Genv.find_comp at 2. unfold Genv.find_funct in *. des_ifs. *) - (* setoid_rewrite ALLOWED. unfold Genv.type_of_call. rewrite Pos.eqb_sym, Heq. auto. *) - (* } *) - (* { replace (funsig (Internal f3)) with sig3; auto. unfold match_cur_stack in MTST0. des_ifs. } *) - (* { rewrite COMP. rewrite PC_RA. simpl. rewrite NEXTPC. simpl. unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. *) - (* replace (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) with (Genv.find_comp ge (Vptr b Ptrofs.zero)); auto. *) - (* rewrite <- ALLOWED. unfold Genv.find_comp. unfold Genv.find_funct. des_ifs. *) - (* } *) + (** return is ccc --- next is poped from the stack, which is internal, so done *) + simpl in *. rewrite Pregmap.gss in *. rename H6 into STAR. + unfold Genv.type_of_call in H. des_ifs. clear H. unfold update_stack_return in STUPD. rewrite Pregmap.gss in *. + 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 *. destruct WFASM as [WFASM1 WFASM2]. + inv WFASM1. simpl in *. des_ifs. clear H8. inv MTST2. + exploit (IH _ _ _ _ _ _ _ _ STAR). lia. all: auto. + { simpl. split; auto. unfold wf_regset. rewrite Pregmap.gss. rewrite PC_RA. rewrite Heq0. auto. } + { instantiate (4:=f'). instantiate (3:=m'0). instantiate (2:=[]). instantiate (1:=Some (next, m2', ik_tl)). simpl. split. + { inv WFIR1. simpl in *. auto. } + split. + { inv WFIR1. auto. } + split; auto. split. + { unfold match_cur_regset. rewrite Pregmap.gss. rewrite COMP. rewrite PC_RA. auto. } + split; auto. split; auto. simpl. split; auto. split; auto. + { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. + pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. + } + split. + { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. pose proof (public_not_freeable_exec_instr _ _ _ _ _ _ _ _ MEM3 NALLOC H3) as NFREE. + pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC2. + clear - H12 NFREE NALLOC2. unfold public_not_freeable in *. intros. specialize (NFREE _ H). intros CC. apply NFREE; clear NFREE. + eapply external_call_max_perm; eauto. unfold Mem.valid_block. unfold meminj_not_alloc in NALLOC2. + unfold Plt. destruct (Pos.ltb_spec b (Mem.nextblock m')); auto. specialize (NALLOC2 _ H0). congruence. + } + split; auto. constructor. + } + intros (btr & ist' & UTR & ISTAR'). + (* FIX: case analysis on whether extcall is unknown or not *) + exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')] + ++ ((Bundle_return [Event_return (Genv.find_comp_ignore_offset ge (rs' X1)) (Genv.find_comp_ignore_offset ge (rs' PC)) res0] res0) :: btr)), ist'. + simpl. rewrite UTR. split; auto. + econstructor 2. 2: econstructor 2. 3: eapply ISTAR'. 3,4: auto. + - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. + { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. + rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. + unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. + } + { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } + - inv WFIR1. simpl in *. des_ifs. clear H8. unfold wf_ir_cur in WFIR0. des_ifs. clear WFIR0. + eapply ir_step_vr_return_internal. 6: eapply Heq1. all: eauto. + { intros. eapply NO_CROSS_PTR. + rewrite PC_RA, NEXTPC. simpl. rewrite <- COMP. rewrite MTST1 in H. + rewrite <- ALLOWED. rewrite H0 in H. simpl in H. unfold Genv.find_comp at 2 in H. unfold Genv.find_funct in H. des_ifs. + } + constructor; auto. + { rewrite COMP, MTST1. rewrite PC_RA, NEXTPC in *. simpl in *. rewrite H0. simpl. unfold Genv.find_comp at 2. unfold Genv.find_funct in *. des_ifs. + setoid_rewrite ALLOWED. unfold Genv.type_of_call. rewrite Pos.eqb_sym, Heq. auto. + } + { replace (funsig (Internal f3)) with sig3; auto. unfold match_cur_stack in MTST0. des_ifs. } + { rewrite COMP. rewrite PC_RA. simpl. rewrite NEXTPC. simpl. unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. + replace (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) with (Genv.find_comp ge (Vptr b Ptrofs.zero)); auto. + rewrite <- ALLOWED. unfold Genv.find_comp. unfold Genv.find_funct. des_ifs. + } Admitted. From f2746a64973167fdf87f7bf42332cc7902dfaa05 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 27 Jul 2023 20:46:17 +0200 Subject: [PATCH 084/174] WIP --- security/BtInfoAsm.v | 128 +++++++------------------------------------ 1 file changed, 21 insertions(+), 107 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 8cd1125149..869bcf9cfc 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -926,7 +926,7 @@ Section PROOF. inv H; simpl in *; rewrite Pregmap.gss in *; rewrite STUCK in H5; inv H5. Qed. - Lemma asm_to_ir_returnstate_undef_ccc_external + Lemma asm_to_ir_returnstate_ccc_external cpm (ge: genv) n n0 (LT: (n0 < n)%nat) (IH: forall y : nat, @@ -949,7 +949,6 @@ Section PROOF. (MTST2 : match_stack ge ik st) k d m_a0 m_i m_a (MEM: match_mem ge 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'' @@ -967,119 +966,34 @@ Section PROOF. inv STEP. inv EV; simpl in *. { rewrite CCC in H. congruence with H. } clear H. - (* TODO *) (** return is ccc --- next is poped from the stack, which is internal, so done *) - simpl in *. rewrite Pregmap.gss in *. rename H6 into STAR. - unfold Genv.type_of_call in H. des_ifs. clear H. unfold update_stack_return in STUPD. rewrite Pregmap.gss in *. - 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 *. destruct WFASM as [WFASM1 WFASM2]. - inv WFASM1. simpl in *. des_ifs. clear H8. inv MTST2. + 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. exploit (IH _ _ _ _ _ _ _ _ STAR). lia. all: auto. - { simpl. split; auto. unfold wf_regset. rewrite Pregmap.gss. rewrite PC_RA. rewrite Heq0. auto. } - { instantiate (4:=f'). instantiate (3:=m'0). instantiate (2:=[]). instantiate (1:=Some (next, m2', ik_tl)). simpl. split. + { simpl. split; auto. unfold wf_regset. rewrite PC_RA. rewrite Heq0. auto. } + { instantiate (4:=k). instantiate (3:=m_a0). instantiate (2:=d). + instantiate (1:=Some (next, m_i, ik_tl)). simpl. splits; auto. { inv WFIR1. simpl in *. auto. } - split. { inv WFIR1. auto. } - split; auto. split. - { unfold match_cur_regset. rewrite Pregmap.gss. rewrite COMP. rewrite PC_RA. auto. } - split; auto. split; auto. simpl. split; auto. split; auto. - { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. - pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. - } - split. - { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. pose proof (public_not_freeable_exec_instr _ _ _ _ _ _ _ _ MEM3 NALLOC H3) as NFREE. - pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC2. - clear - H12 NFREE NALLOC2. unfold public_not_freeable in *. intros. specialize (NFREE _ H). intros CC. apply NFREE; clear NFREE. - eapply external_call_max_perm; eauto. unfold Mem.valid_block. unfold meminj_not_alloc in NALLOC2. - unfold Plt. destruct (Pos.ltb_spec b (Mem.nextblock m')); auto. specialize (NALLOC2 _ H0). congruence. - } - split; auto. constructor. + { unfold match_cur_regset. rewrite COMP. rewrite PC_RA. auto. } + { split; auto. } } intros (btr & ist' & UTR & ISTAR'). - (* FIX: case analysis on whether extcall is unknown or not *) - exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')] - ++ ((Bundle_return [Event_return (Genv.find_comp_ignore_offset ge (rs' X1)) (Genv.find_comp_ignore_offset ge (rs' PC)) res0] res0) :: btr)), ist'. + exists ((Bundle_return [Event_return (Genv.find_comp_ignore_offset ge (rs PC)) (Genv.find_comp ge (Vptr cur Ptrofs.zero)) res] res) :: btr), ist'. simpl. rewrite UTR. split; auto. - econstructor 2. 2: econstructor 2. 3: eapply ISTAR'. 3,4: auto. - - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. - { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. - rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. - unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. - } - { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } - - inv WFIR1. simpl in *. des_ifs. clear H8. unfold wf_ir_cur in WFIR0. des_ifs. clear WFIR0. - eapply ir_step_vr_return_internal. 6: eapply Heq1. all: eauto. - { intros. eapply NO_CROSS_PTR. - rewrite PC_RA, NEXTPC. simpl. rewrite <- COMP. rewrite MTST1 in H. - rewrite <- ALLOWED. rewrite H0 in H. simpl in H. unfold Genv.find_comp at 2 in H. unfold Genv.find_funct in H. des_ifs. - } - constructor; auto. - { rewrite COMP, MTST1. rewrite PC_RA, NEXTPC in *. simpl in *. rewrite H0. simpl. unfold Genv.find_comp at 2. unfold Genv.find_funct in *. des_ifs. - setoid_rewrite ALLOWED. unfold Genv.type_of_call. rewrite Pos.eqb_sym, Heq. auto. - } - { replace (funsig (Internal f3)) with sig3; auto. unfold match_cur_stack in MTST0. des_ifs. } - { rewrite COMP. rewrite PC_RA. simpl. rewrite NEXTPC. simpl. unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. - replace (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) with (Genv.find_comp ge (Vptr b Ptrofs.zero)); auto. - rewrite <- ALLOWED. unfold Genv.find_comp. unfold Genv.find_funct. des_ifs. - } - - - - - - (* garbage *) - move STEP after STAR. inv STEP. - (* invalid *) - 1,2,3,4: rewrite NEXTPC in H2; inv H2; rewrite NEXTF in H3; inv H3. - (** external & InternalCall & next PC is Vundef *) - rewrite NEXTPC in H2; inv H2; rewrite NEXTF in H3; inv H3. - - - clear args H5 H8 VISFO. - assert (STUCK: (set_pair (loc_external_result (ef_sig ef0)) res (undef_caller_save_regs rs)) - # PC <- (rs X1) PC = Vundef). - { rewrite Pregmap.gss. auto. } - (* 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. *) - - (* (* reestablish meminj *) *) - (* exploit mem_delta_apply_establish_inject. eapply MEMINJ'2. eapply INCRINJ. *) - (* { admit. (* ez *) } *) - (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. *) - (* pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. *) - (* } *) - (* { econstructor 1. } *) - (* { simpl; eauto. } *) - (* { admit. (* VISFO0, FIX - unknown or not *) } *) - (* simpl. intros (m3' & TEMPEQ & MEMINJ''). symmetry in TEMPEQ. inv TEMPEQ. *) - (* exploit external_call_mem_inject. *) - (* 2:{ eapply H10. } *) - (* 2:{ eapply MEMINJ''. } *) - (* { admit. } *) - (* { instantiate (1:=args0). admit. } *) - (* intros (f'' & vres'' & m3' & EXTCALL'' & VALINJ'' & MEMINJ'3 & _ & _ & INCRINJ'' & _). *) - - exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d'); Bundle_call t0 ef_id2 (vals_to_eventvals ge args0) (ef_sig ef0) (Some [])]). simpl. - eexists. split; auto. econstructor 2. 2: econstructor 2. 3: econstructor 1. 3,4: eauto. - - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. - { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. - rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. - unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. - } - { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } - - eapply ir_step_intra_call_external. 2: eapply FINDSYMB2. 2: eapply NEXTF2. 6: eapply EXTCALL''. all: eauto. - { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. - rewrite H1. setoid_rewrite ALLOWED. rewrite NEXTPC in REC_CURCOMP; simpl in *. rewrite REC_CURCOMP. - unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. rewrite <- Heq. unfold Genv.find_comp, Genv.find_funct. des_ifs. - unfold Genv.type_of_call. unfold comp_of at 1. simpl. rewrite Pos.eqb_refl; auto. - } - { admit. (* fix? VISFO0 --- maybe case analysis first on unknowns? *) } - } - + 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_vr_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 in MTST0. des_ifs. } + Qed. + (* TODO *) Lemma asm_to_ir_returnstate_undef cpm (ge: genv) n n0 (LT: (n0 < n)%nat) From 7985b3949af89392ab2ee2cc72555aa40fd027cb Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 28 Jul 2023 22:40:25 +0200 Subject: [PATCH 085/174] WIP --- common/Events.v | 30 +++- riscV/Asm.v | 6 +- security/BtInfoAsm.v | 337 +++++++++++++++---------------------------- 3 files changed, 147 insertions(+), 226 deletions(-) diff --git a/common/Events.v b/common/Events.v index 2d69acffb3..9ef89dc0a4 100644 --- a/common/Events.v +++ b/common/Events.v @@ -2162,7 +2162,7 @@ Section VISIBLE. | _ => True end. - Definition visible_fo_if_unknown + 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 @@ -2176,7 +2176,7 @@ Section VISIBLE. | _ => True end. - Definition visible_fo_and_unknown + 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 @@ -2189,6 +2189,32 @@ Section VISIBLE. | _ => 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 => + match lookup_builtin_function name sg with + | None => False + | _ => True + end + | EF_inline_asm cp txt sg clb => False + | _ => (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 + | _ => (tr = E0) /\ (external_call ef ge args m E0 rv m') + end. + (* Remove? *) (* (* Should be ensured by the user *) *) diff --git a/riscV/Asm.v b/riscV/Asm.v index 2bbfe71d8a..08e829641d 100644 --- a/riscV/Asm.v +++ b/riscV/Asm.v @@ -1399,7 +1399,7 @@ 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'). -(* Two fixes: check sig when call CALLSIG, public & first order args when undefined external call VISFO *) +(* Two fixes: check sig when call CALLSIG, public & first order args when undefined external call ECC *) Inductive step_fix: state -> trace -> state -> Prop := | exec_step_fix_internal: forall b ofs f i rs m rs' m' b' ofs' st cp, @@ -1484,7 +1484,7 @@ Inductive step_fix: state -> trace -> state -> Prop := (undef_regs (map preg_of (destroyed_by_builtin ef)) (rs #X1 <- Vundef #X31 <- Vundef))) -> (* Limit leaks when calling unknown function *) - forall (VISFO: visible_fo_if_unknown ef ge m vargs), + 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, @@ -1497,7 +1497,7 @@ Inductive step_fix: state -> trace -> state -> Prop := (* 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 (VISFO: visible_fo_if_unknown ef ge m args), + forall (ECC: external_call_conds ef ge m args), step_fix (State st rs m) t (ReturnState st rs' m'). End RELSEM. diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 869bcf9cfc..df22ad253a 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -148,6 +148,29 @@ Section EVENT. End EVENT. +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. + + Section IR. Variant ir_cont_type : Type := | ir_cont: block -> ir_cont_type. @@ -207,7 +230,8 @@ Section IR. (MEM: mem_delta_apply_inj (meminj_public ge) d (Some m1) = Some m1') vargs vretv (EC: external_call ef ge vargs m1' tr vretv m2) - (VISFO: visible_fo_and_unknown ef ge m1' vargs) + (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ + (external_call_known_observables ef ge m1' vargs tr vretv m2)) (ARGS: evargs = vals_to_eventvals ge vargs) : ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg (Some d)) (Some (cur, m2, ik)) @@ -220,7 +244,8 @@ Section IR. (MEM: mem_delta_apply_inj (meminj_public ge) d (Some m1) = Some m1') vargs vretv (EC: external_call ef ge vargs m1' tr vretv m2) - (VISFO: visible_fo_and_unknown ef ge m1' vargs) + (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ + (external_call_known_observables ef ge m1' vargs tr vretv m2)) (ARGS: evargs = vals_to_eventvals ge vargs) : ir_step ge (Some (cur, m1, ik)) (Bundle_builtin tr ef evargs d) (Some (cur, m2, ik)) @@ -253,13 +278,14 @@ Section IR. (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_vr ge cp cp' b vargs (sig_args sg) tr1 id evargs) + (TR1: call_trace_vr ge cp cp' b vargs (sig_args sg) tr1 id evargs) (* external function part *) d m1' (MEM: mem_delta_apply_inj (meminj_public ge) d (Some m1) = Some m1') tr2 m2 vretv - (EC: external_call ef ge vargs m1' tr2 vretv m2) - (VISFO: visible_fo_and_unknown ef ge m1' vargs) + (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)) (ARGS: evargs = vals_to_eventvals ge vargs) : ir_step ge (Some (cur, m1, ik)) (Bundle_call (tr1 ++ tr2) id evargs sg (Some d)) None @@ -282,7 +308,8 @@ Section IR. (MEM: mem_delta_apply_inj (meminj_public ge) d (Some m1) = Some m1') tr2 m2 vretv (TR2: external_call ef ge vargs m1' tr2 vretv m2) - (VISFO: visible_fo_and_unknown ef ge m1' vargs) + (ECCASES: (external_call_unknowns ef ge m1' vargs) \/ + (external_call_known_observables ef ge m1' vargs tr2 vretv m2)) (ARGS: evargs = vals_to_eventvals ge vargs) (* return part *) tr3 evretv @@ -421,26 +448,6 @@ Section FROMASM. simpl. Definition public_not_freeable ge m := forall b, (meminj_public ge b <> None) -> (~ Mem.perm m b 0 Max Freeable). -(* Definition public_not_freeable ge m := forall b, (meminj_public ge b <> None) -> (~ Mem.perm m b 0 Cur Freeable). *) -(* Genv.alloc_global = *) -(* fun (F V : Type) (CF : has_comp F) (ge : Genv.t F V) (m : mem) (idg : ident * globdef F V) => *) -(* let (_, g) := idg in *) -(* match g with *) -(* | Gfun f => let (m1, b) := Mem.alloc m (comp_of f) 0 1 in Mem.drop_perm m1 b 0 1 Nonempty (comp_of f) *) -(* | Gvar v => *) -(* let init := gvar_init v in *) -(* let comp := gvar_comp v in *) -(* let sz := init_data_list_size init in *) -(* let (m1, b) := Mem.alloc m comp 0 sz in *) -(* match store_zeros m1 b 0 sz comp with *) -(* | Some m2 => match Genv.store_init_data_list ge m2 b 0 init comp with *) -(* | Some m3 => Mem.drop_perm m3 b 0 sz (Genv.perm_globvar v) comp *) -(* | None => None *) -(* end *) -(* | None => None *) -(* end *) -(* end *) -(* : forall F V : Type, has_comp F -> Genv.t F V -> mem -> ident * globdef F V -> option mem *) Lemma mem_delta_exec_instr (ge: genv) f i rs m cp rs' m' @@ -579,14 +586,8 @@ Section INVS. end. Definition wf_ir_conts (ge: Asm.genv) (ik: ir_conts) := Forall (wf_ir_cont ge) ik. - (* Definition wf_ir (ge: Asm.genv) (ist: ir_state) := *) - (* match ist with *) - (* | Some (_, _, ik) => (wf_ir_conts ge ik) *) - (* | _ => False *) - (* end. *) - - Definition match_cur_stack (cur: block) (ge: Asm.genv) (sk: stack) := + 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 @@ -603,20 +604,11 @@ Section INVS. 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 next ge sk_tl) + (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). - (* Variant match_stackframe (ge: Asm.genv) : ir_cont_type -> stackframe -> Prop := *) - (* | match_stackframe_intro *) - (* b1 b2 cp sg v ofs *) - (* (COMP: Genv.find_comp ge (Vptr b1 Ptrofs.zero) = Genv.find_comp ge (Vptr b2 Ptrofs.zero)) *) - (* : *) - (* match_stackframe ge (ir_cont b1) (Stackframe b2 cp sg v ofs). *) - (* Definition match_stack (ge: Asm.genv) (ik: ir_conts) (st: stack) := *) - (* Forall2 (match_stackframe ge) ik st. *) - Definition match_mem (ge: Senv.t) (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) /\ @@ -627,7 +619,7 @@ Section INVS. 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 cur ge sk) /\ (match_cur_regset cur ge rs) /\ + (match_cur_stack_sig cur ge sk) /\ (match_cur_regset cur ge rs) /\ (match_stack ge ik sk) /\ (match_mem ge k d m_a0 m_i m_a) | _, _ => False end. @@ -693,7 +685,7 @@ Section PROOF. (WFIR1 : wf_ir_conts ge ik) st (rs: regset) (WFASM1: wf_stack ge st) - (MTST0 : match_cur_stack cur 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 @@ -739,26 +731,7 @@ Section PROOF. exists btr, ist'. split; auto. Qed. - Definition extcall_known (ef: external_function) (ge: Senv.t) args := - match ef with - | EF_builtin _ name sg | EF_runtime _ name sg => - match Builtins.lookup_builtin_function name sg with - | Some _ => True - | None => False - end - | EF_memcpy _ _ _ => EF_memcpy_dest_not_pub ge args - | EF_external _ _ sg | EF_inline_asm _ _ sg _ => False - | _ => True - end. - - Lemma extcall_cases - ef ge m args - (VIS: visible_fo_if_unknown ef ge m args) - : - (visible_fo_and_unknown ef ge m args) \/ (extcall_known ef ge args). - Proof. destruct ef; simpl in *; auto. des_ifs; auto. des_ifs; auto. Qed. - - Lemma asm_to_ir_step_nccc_external + Lemma asm_to_ir_step_external cpm (ge: genv) (WFGE: wf_ge ge) cur ik @@ -766,7 +739,7 @@ Section PROOF. (WFIR1 : wf_ir_conts ge ik) st (rs: regset) (WFASM1: wf_stack ge st) - (MTST0 : match_cur_stack cur 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 @@ -797,13 +770,13 @@ Section PROOF. 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. - apply extcall_cases in VISFO. destruct VISFO as [VISFO | KNOWN]. + exploit extcall_cases. eapply ECC. eauto. clear ECC. intros [ECU | [ECKO | ECKS]]. - (* extcall is unknown *) (* reestablish meminj *) exploit mem_delta_apply_establish_inject; eauto. { admit. (* ez *) } - { admit. (* VISFO *) } + { admit. (* ECU *) } intros (m_i' & APPD' & MEMINJ'). exploit external_call_mem_inject; eauto. { admit. (* ez *) } { instantiate (1:=args). admit. } @@ -835,10 +808,33 @@ Section PROOF. { 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. } - { clear - VISFO MEMINJ'. admit. (* TODO *) }. + { clear - ECU MEMINJ'. left. admit. (* TODO *) }. - (* extcall is known *) - (* TODO *) + rename H4 into EXTCALL, H7 into EXTARGS. unfold external_call_known_observables in ECKO. + des_ifs; simpl in *. + { 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: split; 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: split; auto. 2: eauto. econstructor 1. + } + { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. + exists ([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 |} (Some [])]). + 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. } + { simpl. eauto. } + { simpl. econstructor. econstructor 1; eauto. } + { simpl. right. econs; eauto. econs. econs; eauto. } + { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. } + } + { + (* TODO *) + + + Admitted. @@ -860,7 +856,7 @@ Section PROOF. (WFIR1 : wf_ir_conts ge ik) st (rs: regset) (WFASM1: wf_stack ge st) - (MTST0 : match_cur_stack cur 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 @@ -893,7 +889,7 @@ Section PROOF. 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_nccc_external. + exploit asm_to_ir_step_external. 12: eapply STAR. 11: eapply NEXTF. 10: eapply NEXTPC. 9: eapply STEP. all: eauto. { split; eauto. } @@ -926,7 +922,7 @@ Section PROOF. inv H; simpl in *; rewrite Pregmap.gss in *; rewrite STUCK in H5; inv H5. Qed. - Lemma asm_to_ir_returnstate_ccc_external + Lemma asm_to_ir_returnstate_ccc cpm (ge: genv) n n0 (LT: (n0 < n)%nat) (IH: forall y : nat, @@ -944,7 +940,7 @@ Section PROOF. (WFIR1 : wf_ir_conts ge ik) st (rs: regset) (WFASM1: wf_stack ge st) - (MTST0 : match_cur_stack cur 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 @@ -954,10 +950,6 @@ Section PROOF. 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) - 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. @@ -990,10 +982,9 @@ Section PROOF. { 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 in MTST0. des_ifs. } + { replace (funsig (Internal f2)) with sig3; auto. unfold match_cur_stack_sig in MTST0. des_ifs. } Qed. - (* TODO *) Lemma asm_to_ir_returnstate_undef cpm (ge: genv) n n0 (LT: (n0 < n)%nat) @@ -1012,7 +1003,7 @@ Section PROOF. (WFIR1 : wf_ir_conts ge ik) st (rs: regset) (WFASM1: wf_stack ge st) - (MTST0 : match_cur_stack cur 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 @@ -1028,7 +1019,6 @@ Section PROOF. destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5). (** 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 *) @@ -1037,150 +1027,21 @@ Section PROOF. 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. split; eauto. } - - (* TODO *) - (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) - (* take a step *) - inv STEP. - (* invalid *) - 1,2,3,4: rewrite Pregmap.gss in H8; inv H8; rewrite NEXTF2 in H9; inv H9. - (** external & InternalCall & next PC is Vundef *) - rewrite Pregmap.gss in H8; inv H8. rewrite NEXTF2 in H9; inv H9. - assert (STUCK: ((set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (Vptr b2 Ptrofs.zero) X1) = Vundef). - { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } - rewrite STUCK in STAR. - exploit Genv.find_funct_ptr_iff. intros (TEMP & _). specialize (TEMP NEXTF2). exploit wf_ge_block_to_id; eauto. intros (ef_id2 & INVSYMB2). - exploit Genv.invert_find_symbol. eapply INVSYMB2. intros FINDSYMB2. clear TEMP. - (* reestablish meminj *) - exploit mem_delta_apply_establish_inject. eapply MEMINJ'2. eapply INCRINJ. - { admit. (* ez *) } - { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. - pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. - } - { econstructor 1. } - { simpl; eauto. } - { admit. (* VISFO0, FIX - unknown or not *) } - simpl. intros (m3' & TEMPEQ & MEMINJ''). symmetry in TEMPEQ. inv TEMPEQ. - exploit external_call_mem_inject. - 2:{ eapply H10. } - 2:{ eapply MEMINJ''. } - { admit. } - { instantiate (1:=args0). admit. } - intros (f'' & vres'' & m3' & EXTCALL'' & VALINJ'' & MEMINJ'3 & _ & _ & INCRINJ'' & _). - inv STAR. - (* end case *) - { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d'); Bundle_call t0 ef_id2 (vals_to_eventvals ge args0) (ef_sig ef0) (Some [])]). simpl. - eexists. split; auto. econstructor 2. 2: econstructor 2. 3: econstructor 1. 3,4: eauto. - - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. - { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. - rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. - unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. - } - { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } - - eapply ir_step_intra_call_external. 2: eapply FINDSYMB2. 2: eapply NEXTF2. 6: eapply EXTCALL''. all: eauto. - { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. - rewrite H1. setoid_rewrite ALLOWED. rewrite NEXTPC in REC_CURCOMP; simpl in *. rewrite REC_CURCOMP. - unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. rewrite <- Heq. unfold Genv.find_comp, Genv.find_funct. des_ifs. - unfold Genv.type_of_call. unfold comp_of at 1. simpl. rewrite Pos.eqb_refl; auto. - } - { admit. (* fix? VISFO0 --- maybe case analysis first on unknowns? *) } + { exploit asm_to_ir_returnstate_undef_nccc_external. 2: eapply IH. + 12: eapply STAR0. 11: eapply STEP0. all: eauto. split; eauto. } - inv H; simpl in *. rewrite Pregmap.gss in *. inv H6. - (* end case *) - { inv EV. - (* return is NCCC - silent *) - { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d'); Bundle_call t0 ef_id2 (vals_to_eventvals ge args0) (ef_sig ef0) (Some [])]). simpl. - eexists. split; auto. econstructor 2. 2: econstructor 2. 3: econstructor 1. 3,4: eauto. - - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. - { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. - rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. - unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. - } - { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } - - eapply ir_step_intra_call_external. 2: eapply FINDSYMB2. 2: eapply NEXTF2. 6: eapply EXTCALL''. all: eauto. - { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. - rewrite H1. setoid_rewrite ALLOWED. rewrite NEXTPC in REC_CURCOMP; simpl in *. rewrite REC_CURCOMP. - unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. rewrite <- Heq. unfold Genv.find_comp, Genv.find_funct. des_ifs. - unfold Genv.type_of_call. unfold comp_of at 1. simpl. rewrite Pos.eqb_refl; auto. - } - { admit. (* fix? VISFO0 --- maybe case analysis first on unknowns? *) } - } - (* 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 *. - replace (Genv.find_comp_ignore_offset ge Vundef) with default_compartment in STUPD0; auto. 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 --- by some hacky reason *) - clear - PC_RA0. exfalso. simpl in PC_RA0. des_ifs. - } - } - (* stuck case *) - inv H; simpl in *; rewrite Pregmap.gss in *; inv H11. } - (** return is ccc --- next is poped from the stack, which is internal, so done *) - simpl in *. rewrite Pregmap.gss in *. rename H6 into STAR. - unfold Genv.type_of_call in H. des_ifs. clear H. unfold update_stack_return in STUPD. rewrite Pregmap.gss in *. - 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 *. destruct WFASM as [WFASM1 WFASM2]. - inv WFASM1. simpl in *. des_ifs. clear H8. inv MTST2. - exploit (IH _ _ _ _ _ _ _ _ STAR). lia. all: auto. - { simpl. split; auto. unfold wf_regset. rewrite Pregmap.gss. rewrite PC_RA. rewrite Heq0. auto. } - { instantiate (4:=f'). instantiate (3:=m'0). instantiate (2:=[]). instantiate (1:=Some (next, m2', ik_tl)). simpl. split. - { inv WFIR1. simpl in *. auto. } - split. - { inv WFIR1. auto. } - split; auto. split. - { unfold match_cur_regset. rewrite Pregmap.gss. rewrite COMP. rewrite PC_RA. auto. } - split; auto. split; auto. simpl. split; auto. split; auto. - { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. - pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. - } - split. - { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. pose proof (public_not_freeable_exec_instr _ _ _ _ _ _ _ _ MEM3 NALLOC H3) as NFREE. - pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC2. - clear - H12 NFREE NALLOC2. unfold public_not_freeable in *. intros. specialize (NFREE _ H). intros CC. apply NFREE; clear NFREE. - eapply external_call_max_perm; eauto. unfold Mem.valid_block. unfold meminj_not_alloc in NALLOC2. - unfold Plt. destruct (Pos.ltb_spec b (Mem.nextblock m')); auto. specialize (NALLOC2 _ H0). congruence. - } - split; auto. constructor. + { exploit asm_to_ir_returnstate_ccc. 2: eapply IH. + 11: eapply STAR. 10: eapply STEP0. all: eauto. split; eauto. } - intros (btr & ist' & UTR & ISTAR'). - (* FIX: case analysis on whether extcall is unknown or not *) - exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')] - ++ ((Bundle_return [Event_return (Genv.find_comp_ignore_offset ge (rs' X1)) (Genv.find_comp_ignore_offset ge (rs' PC)) res0] res0) :: btr)), ist'. - simpl. rewrite UTR. split; auto. - econstructor 2. 2: econstructor 2. 3: eapply ISTAR'. 3,4: auto. - - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. - { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. - rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. - unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. - } - { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } - - inv WFIR1. simpl in *. des_ifs. clear H8. unfold wf_ir_cur in WFIR0. des_ifs. clear WFIR0. - eapply ir_step_vr_return_internal. 6: eapply Heq1. all: eauto. - { intros. eapply NO_CROSS_PTR. - rewrite PC_RA, NEXTPC. simpl. rewrite <- COMP. rewrite MTST1 in H. - rewrite <- ALLOWED. rewrite H0 in H. simpl in H. unfold Genv.find_comp at 2 in H. unfold Genv.find_funct in H. des_ifs. - } - constructor; auto. - { rewrite COMP, MTST1. rewrite PC_RA, NEXTPC in *. simpl in *. rewrite H0. simpl. unfold Genv.find_comp at 2. unfold Genv.find_funct in *. des_ifs. - setoid_rewrite ALLOWED. unfold Genv.type_of_call. rewrite Pos.eqb_sym, Heq. auto. - } - { replace (funsig (Internal f3)) with sig3; auto. unfold match_cur_stack in MTST0. des_ifs. } - { rewrite COMP. rewrite PC_RA. simpl. rewrite NEXTPC. simpl. unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. - replace (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) with (Genv.find_comp ge (Vptr b Ptrofs.zero)); auto. - rewrite <- ALLOWED. unfold Genv.find_comp. unfold Genv.find_funct. des_ifs. - } + Qed. - Admitted. (* If main is External, treat it as a different case - the trace can start with Event_syscall, without a preceding Event_call *) @@ -1244,6 +1105,42 @@ Section PROOF. (* end case *) { end_case. } (* take a step *) + destruct WFASM as [WFASM0 WFASM1]. + exploit asm_to_ir_step_external. 12: eapply H6. 11: eapply NEXTF. 10: eapply NEXTPC. 9: eapply H. all: eauto. + { inv H. + 1,2,3,4: rewrite NEXTPC in H10; inv H10; rewrite NEXTF in H11; inv H11. + rewrite <- REC_CURCOMP. rewrite H10. rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H10; inv H10. 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. + } + 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, H6 into STAR0. + inv STAR'. + { end_case. } + exploit asm_to_ir_returnstate_undef. 2: eapply IH. 12: eapply H6. 11: eapply H. 9: eapply MM'. all: eauto. + { inv STEP0. + 1,2,3,4: rewrite NEXTPC in H10; inv H10; rewrite NEXTF in H11; inv H11. + rewrite <- REC_CURCOMP. rewrite H10. rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H10; inv H10. 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. } + } + + - (** internal_call *) + (*** TODO *) + + inv H; simpl in *; try rewrite Pregmap.gss in *. inv EV. + 2:{ ex + rewrite <- REC_CURCOMP. rewrite H10. rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H10; inv H10. rewrite <- ALLOWED. + unfold Genv.find_comp. setoid_rewrite H1. auto. + } + { + inv H. (* invalid *) 1,2,3,4: rewrite NEXTPC in H10; inv H10; rewrite NEXTF in H11; inv H11. @@ -1277,7 +1174,7 @@ Section PROOF. } destruct WFASM as [WFASM0 WFASM1]. - exploit asm_to_ir_returnstate0. 2: eapply IH. 11: eapply H. 11: eapply H6. all: auto. 1,2,3: eauto. all: auto. + exploit asm_to_ir_returnstate_undef. 2: eapply IH. 11: eapply H. 11: eapply H6. all: auto. 1,2,3: eauto. all: auto. { unfold match_cur_regset in *. simpl in *. rewrite <- REC_CURCOMP. rewrite NEXTPC. simpl. rewrite <- ALLOWED. rewrite MTST1, H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite H1. auto. } @@ -1307,7 +1204,7 @@ Section PROOF. { admit. (* FIX: at exists, if knowns, empty event, unknown case uses VISFO --- case analysis first on unknowns? *) } } - (*** lemma here *) + (* (** steps --- ReturnState *) *) (* inv H. inv EV; simpl in *. *) (* (** return is nccc *) *) @@ -1500,15 +1397,13 @@ Section PROOF. (* { rewrite COMP, MTST1. rewrite PC_RA, NEXTPC in *. simpl in *. rewrite H0. simpl. unfold Genv.find_comp at 2. unfold Genv.find_funct in *. des_ifs. *) (* setoid_rewrite ALLOWED. unfold Genv.type_of_call. rewrite Pos.eqb_sym, Heq. auto. *) (* } *) - (* { replace (funsig (Internal f3)) with sig3; auto. unfold match_cur_stack in MTST0. des_ifs. } *) + (* { replace (funsig (Internal f3)) with sig3; auto. unfold match_cur_stack_sig in MTST0. des_ifs. } *) (* { rewrite COMP. rewrite PC_RA. simpl. rewrite NEXTPC. simpl. unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. *) (* replace (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) with (Genv.find_comp ge (Vptr b Ptrofs.zero)); auto. *) (* rewrite <- ALLOWED. unfold Genv.find_comp. unfold Genv.find_funct. des_ifs. *) (* } *) (* } *) - - (** internal_call *) - (* TODO *) From 6be83142f8775b42aa287028bb3a06bf67fc3565 Mon Sep 17 00:00:00 2001 From: ldj Date: Sat, 29 Jul 2023 17:51:45 +0200 Subject: [PATCH 086/174] WIP --- common/Events.v | 4 +- security/BtInfoAsm.v | 298 ++++++++++++++++++++++++++++++++++--------- 2 files changed, 242 insertions(+), 60 deletions(-) diff --git a/common/Events.v b/common/Events.v index 9ef89dc0a4..5cfe6a837e 100644 --- a/common/Events.v +++ b/common/Events.v @@ -2212,7 +2212,9 @@ Section VISIBLE. | _ => True end | EF_inline_asm cp txt sg clb => False - | _ => (tr = E0) /\ (external_call ef ge args m E0 rv m') + | 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. diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index df22ad253a..8bd15563dc 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -14,23 +14,44 @@ Require Import BtBasics. -Section BUNDLE. +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. + - (* (* ()-no event, {}-may event, when len(tr) > 1, need to consider cuts *) *) - (* (* intra/cross/virtual(default), internal/external *) *) - (* Variant bundle_event : Type := *) - (* (* generate a call code + other followup events *) *) - (* | Bundle_call_ci (tr: trace) (id: ident) (args: list eventval) (sg: signature) (* call *) *) - (* | Bundle_call_ce (tr: trace) (id: ident) (args: list eventval) (sg: signature) (* call-{ext}-ret - cut at {1, 2, 3} *) *) - (* | Bundle_call_vi (tr: trace) (id: ident) (args: list eventval) (sg: signature) (* (call) - compartment changes *) *) - (* | Bundle_call_ve (tr: trace) (id: ident) (args: list eventval) (sg: signature) (* (call)-ext-(ret) - also cut *) *) - (* | Bundle_call_ie (tr: trace) (id: ident) (args: list eventval) (sg: signature) (* (call)-ext-(ret) *) *) - (* (* generate a return code *) *) - (* | Bundle_return_ci (tr: trace) (sg: signature) (* ret *) *) - (* | Bundle_return_vi (tr: trace) (sg: signature) (* (ret) - compartment change *) *) - (* (* generate a builtin code *) *) - (* | Bundle_builtin (tr: trace) (ef: external_function) (* ext *) *) - (* . *) + +Section BUNDLE. Variant bundle_event : Type := (* generate a call code + other followup events; call-ext-ret *) @@ -145,30 +166,28 @@ Section EVENT. Definition vals_to_eventvals (ge: Senv.t) (vs: list val): list eventval := map (val_to_eventval ge) vs. -End EVENT. + 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. -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. Section IR. @@ -447,7 +466,22 @@ Section FROMASM. end); simpl. - Definition public_not_freeable ge m := forall b, (meminj_public ge b <> None) -> (~ Mem.perm m b 0 Max Freeable). + Definition public_not_freeable ge m := forall b, (meminj_public ge b <> None) -> (forall ofs, ~ Mem.perm m b ofs Max Freeable). + + 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 mem_delta_exec_instr (ge: genv) f i rs m cp rs' m' @@ -487,13 +521,63 @@ Section FROMASM. 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. lia. + 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. + 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) @@ -510,12 +594,10 @@ Section FROMASM. | H: context [Mem.alloc] |- _ => idtac | H: context [Mem.free] |- _ => idtac | H: Mem.store ?ch ?m ?b ?ofs ?v ?cp = _ |- _ => - unfold public_not_freeable in *; intros b' H' CC; specialize (NFREE _ H'); apply NFREE; eapply Mem.perm_store_2; eauto + eapply public_not_freeable_store; eauto end). - { unfold public_not_freeable in *; intros b' H' CC; specialize (NFREE _ H'); apply NFREE. eapply Mem.perm_alloc_4; eauto. - eapply Mem.perm_store_2; eauto. intros EQ; subst b'. apply H'. apply NALLOC. erewrite Mem.alloc_result; eauto. lia. - } - { unfold public_not_freeable in *; intros b' H' CC; specialize (NFREE _ H'); apply NFREE. eapply Mem.perm_free_3; eauto. } + { eapply public_not_freeable_store. eapply public_not_freeable_alloc; eauto. eauto. } + { eapply public_not_freeable_free; eauto. } Qed. Lemma meminj_not_alloc_delta @@ -792,7 +874,7 @@ Section PROOF. split. { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. clear - H4 MEM3 NALLOC. unfold public_not_freeable in *. intros. - specialize (MEM3 _ H). intros CC. apply MEM3; clear MEM3. + 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_a)); auto. @@ -810,7 +892,7 @@ Section PROOF. } { clear - ECU MEMINJ'. left. admit. (* TODO *) }. - - (* extcall is known *) + - (* extcall is known and observable *) rename H4 into EXTCALL, H7 into EXTARGS. unfold external_call_known_observables in ECKO. des_ifs; simpl in *. { unfold builtin_or_external_sem in EXTCALL. rewrite Heq in EXTCALL. inv EXTCALL. @@ -830,11 +912,106 @@ Section PROOF. { simpl. right. econs; eauto. econs. econs; eauto. } { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. } } - { - (* TODO *) - + { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. + exists ([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 |} (Some [])]). + 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. } + { simpl. eauto. } + { instantiate (2:=[Vptr b0 ofs; Val.load_result chunk v]). + simpl. econstructor. econstructor 1; eauto. rewrite val_load_result_idem. auto. + } + { simpl. right. econs; eauto. econs. econs; eauto. 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. + } + } + { 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 ([Bundle_call [Event_annot text args0] ef_id (vals_to_eventvals ge args) {| sig_args := targs; sig_res := Tvoid; sig_cc := cc_default |} (Some [])]). + 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. } + { simpl. eauto. } + { simpl. econstructor. auto. } + { simpl. right. econs; eauto. econs. auto. } + } + { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. + exists ([Bundle_call [Event_annot text [arg]] ef_id [val_to_eventval ge res] {| sig_args := [targ]; sig_res := targ; sig_cc := cc_default |} (Some [])]). + 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. } + { simpl. eauto. } + { simpl. econstructor. eauto. } + { simpl. right. econs; eauto. econs. auto. } + { simpl. 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: split; 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: split; 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: split; auto. 2: eauto. econstructor 1. + } + { destruct ECKS as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. + exists [], k, (d ++ [mem_delta_kind_store (chunk, b0, (Ptrofs.unsigned 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. simpl. auto. } + { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } + } + { 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. auto. + } + { rewrite mem_delta_apply_app. rewrite MEM5. simpl. rewrite H. simpl. 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. } + - 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. } + } + { 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: split; auto. 2: eauto. econstructor 1. + } Admitted. @@ -1045,14 +1222,14 @@ Section PROOF. (* If main is External, treat it as a different case - the trace can start with Event_syscall, without a preceding Event_call *) - Lemma 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) + 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. @@ -1098,7 +1275,6 @@ Section PROOF. } exploit IH. 4: eapply STAR. 3: apply WFASM'. 3: eapply MTST'. all: auto. } - (*** Next = internal -> done *) (** has next function --- external *) { move STAR after NEXTF. inv STAR. @@ -1132,6 +1308,10 @@ Section PROOF. } - (** internal_call *) + + + + (*** TODO *) inv H; simpl in *; try rewrite Pregmap.gss in *. inv EV. From 5ef0aeec881ae7377521db177b40559ee9c6d38a Mon Sep 17 00:00:00 2001 From: ldj Date: Sat, 29 Jul 2023 22:21:35 +0200 Subject: [PATCH 087/174] WIP --- security/BtInfoAsm.v | 213 ++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 212 insertions(+), 1 deletion(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 8bd15563dc..9bd38f1f9d 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -890,7 +890,7 @@ Section PROOF. { 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. } - { clear - ECU MEMINJ'. left. admit. (* TODO *) }. + { clear - ECU MEMINJ'. left. admit. (* TODO *) } - (* extcall is known and observable *) rename H4 into EXTCALL, H7 into EXTARGS. unfold external_call_known_observables in ECKO. @@ -1015,6 +1015,183 @@ Section PROOF. Admitted. + 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 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). + destruct WFASM as [WFASM0 WFASM1]. + exploit extcall_cases. eapply ECC. eauto. clear ECC. intros [ECU | [ECKO | ECKS]]. + + - (* extcall is unknown *) + (* reestablish meminj *) + exploit mem_delta_apply_establish_inject; eauto. + { admit. (* ez *) } + { admit. (* ECU *) } + intros (m_i' & APPD' & MEMINJ'). exploit external_call_mem_inject; eauto. + { admit. (* ez *) } + { instantiate (1:=vargs). admit. } + intros (f' & vres' & m_i'' & EXTCALL' & VALINJ' & MEMINJ'' & _ & _ & INCRINJ' & _). + assert (MM': match_mem ge f' [] m' m_i'' m'). + { unfold match_mem. simpl. splits; auto. + { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. + 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. + } + { 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. + } + constructor. + } + exists ([Bundle_builtin t1 ef (vals_to_eventvals ge vargs) d]). + do 4 eexists. splits; simpl. 3: eapply MM'. apply app_nil_r. + econstructor 2. 2: econstructor 1. 2: eauto. + eapply ir_step_builtin; eauto. + { clear - ECU MEMINJ'. left. admit. (* TODO *) } + + - (* extcall is known and observable *) + unfold external_call_known_observables in ECKO. + des_ifs; simpl in *. + { unfold builtin_or_external_sem in EXTCALL. rewrite Heq in EXTCALL. inv EXTCALL. + exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: split; 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: split; auto. econstructor 1. + } + { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. + exists ([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. + { simpl. eauto. } + { simpl. econstructor. econstructor 1; eauto. } + { simpl. right. econs; eauto. econs. econs; eauto. } + { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. } + } + { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. + exists ([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. + { simpl. eauto. } + { instantiate (2:=[Vptr b0 ofs0; Val.load_result chunk v]). + simpl. econstructor. econstructor 1; eauto. rewrite val_load_result_idem. auto. + } + { simpl. right. econs; eauto. econs. econs; eauto. 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. + } + } + { 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 ([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. + { simpl. eauto. } + { simpl. econstructor. auto. } + { simpl. right. econs; eauto. econs. auto. } + } + { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. + exists ([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. + { simpl. eauto. } + { simpl. econstructor. eauto. } + { simpl. right. econs; eauto. econs. auto. } + { simpl. 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: split; 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: split; 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: split; auto. econstructor 1. + } + { destruct ECKS as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. + exists [], k, (d ++ [mem_delta_kind_store (chunk, b0, (Ptrofs.unsigned 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. simpl. auto. } + { rewrite mem_delta_apply_app. rewrite MEM5. simpl. auto. } + } + { 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. auto. + } + { rewrite mem_delta_apply_app. rewrite MEM5. simpl. rewrite H. simpl. 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. } + - 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. } + } + + { 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: split; auto. econstructor 1. + } + + Admitted. + + Lemma asm_to_ir_returnstate_undef_nccc_external cpm (ge: genv) n n0 (LT: (n0 < n)%nat) @@ -1308,7 +1485,41 @@ Section PROOF. } - (** internal_call *) + admit. + + - (** internal_return *) + admit. + + - (** 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 res vres (undef_regs (map preg_of (destroyed_by_builtin ef)) (rs # X1 <- Vundef) # X31 <- Vundef))) as rs'. + (** fix? + after builtin, compartment can be changed since there is no constraint on next PC *) + (*** TODO *) + destruct ( + + + clear H2 H3 H4 + remember + + + + admit. + - (** external *) + exfalso. destruct WFASM as [WFASM0 WFASM1]. unfold wf_regset in WFASM1. + rewrite H0 in WFASM1. rewrite H1 in WFASM1. contradiction WFASM1. From 5a712ac37de1d6690296f4ab9ed78a52e376350b Mon Sep 17 00:00:00 2001 From: ldj Date: Sat, 29 Jul 2023 22:29:35 +0200 Subject: [PATCH 088/174] WIP --- security/BtInfoAsm.v | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 9bd38f1f9d..57848eab29 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -1505,14 +1505,10 @@ Section PROOF. destruct WFASM as [WFASM0 WFASM1]. remember (nextinstr (set_res res vres (undef_regs (map preg_of (destroyed_by_builtin ef)) (rs # X1 <- Vundef) # X31 <- Vundef))) as rs'. (** fix? - after builtin, compartment can be changed since there is no constraint on next PC *) + after builtin, compartment can be changed since there is no constraint on next PC. + In fact, Asmgen ensures that res register of builtin is of form (preg_of r), which is never PC ---> augmenting Asm semantics should be possible? + *) (*** TODO *) - destruct ( - - - clear H2 H3 H4 - remember - admit. @@ -1522,8 +1518,12 @@ Section PROOF. rewrite H0 in WFASM1. rewrite H1 in WFASM1. contradiction WFASM1. + Abort. + + + + - (*** TODO *) inv H; simpl in *; try rewrite Pregmap.gss in *. inv EV. 2:{ ex From e5a9f20065717d7b2438ca7ee662408e29813086 Mon Sep 17 00:00:00 2001 From: ldj Date: Sun, 30 Jul 2023 18:06:33 +0200 Subject: [PATCH 089/174] WIP --- security/BtInfoAsm.v | 28 ++++++++++++++++++++++------ 1 file changed, 22 insertions(+), 6 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 57848eab29..58e1b4f74b 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -1488,6 +1488,11 @@ Section PROOF. admit. - (** internal_return *) + + + + + admit. - (** return *) @@ -1504,14 +1509,25 @@ Section PROOF. clear dependent btr1. clear dependent m_i. rename m_i' into m_i. destruct WFASM as [WFASM0 WFASM1]. remember (nextinstr (set_res res vres (undef_regs (map preg_of (destroyed_by_builtin ef)) (rs # X1 <- Vundef) # X31 <- Vundef))) as rs'. - (** fix? + (* FIX after builtin, compartment can be changed since there is no constraint on next PC. In fact, Asmgen ensures that res register of builtin is of form (preg_of r), which is never PC ---> augmenting Asm semantics should be possible? - *) - (*** TODO *) - - - admit. + *) + assert (NEXTPC: rs' PC = Val.offset_ptr (rs PC) Ptrofs.one). + { subst rs'. clear. unfold nextinstr. simpl. + assert (exists mres, res = (map_builtin_res preg_of mres)). + { admit. (*** FIX *) } + des. subst res. + 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. From 20c754217098c34267c6fb84a32ccc94a38ef2cc Mon Sep 17 00:00:00 2001 From: ldj Date: Sun, 30 Jul 2023 21:41:12 +0200 Subject: [PATCH 090/174] WIP --- security/BtInfoAsm.v | 151 +++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 145 insertions(+), 6 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 58e1b4f74b..ecfba1c8fb 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -621,6 +621,14 @@ Section FROMASM. 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. + End FROMASM. @@ -1385,7 +1393,7 @@ Section PROOF. { exploit asm_to_ir_returnstate_nccc_internal. 2: eapply IH. 11: eapply STAR0. 10: eapply STEP0. all: eauto. split; eauto. } - (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) + (** next is external --- undef *) { exploit asm_to_ir_returnstate_undef_nccc_external. 2: eapply IH. 12: eapply STAR0. 11: eapply STEP0. all: eauto. split; eauto. } @@ -1396,6 +1404,129 @@ Section PROOF. } 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 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). + (** 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. + { split; 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 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). + (** 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. split; 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. split; 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. split; eauto. + } + Qed. + (* If main is External, treat it as a different case - the trace can start with Event_syscall, without a preceding Event_call *) @@ -1485,16 +1616,24 @@ Section PROOF. } - (** internal_call *) - admit. - - - (** internal_return *) - - + (* TODO *) admit. + - (** 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. From 4a6044e5e06b40a08150ea4306ea4168e85cbc71 Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 31 Jul 2023 13:57:16 +0200 Subject: [PATCH 091/174] WIP --- riscV/Asm.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/riscV/Asm.v b/riscV/Asm.v index 08e829641d..dced5744e1 100644 --- a/riscV/Asm.v +++ b/riscV/Asm.v @@ -1475,12 +1475,12 @@ Inductive step_fix: state -> trace -> state -> Prop := 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 res) -> + 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 res vres + (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 *) From 76fd635b165e2bfee1dbd69885a36a9cc9c7dbff Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 31 Jul 2023 19:10:16 +0200 Subject: [PATCH 092/174] WIP --- common/Events.v | 6 +- riscV/Asm.v | 5 +- security/BtInfoAsm.v | 315 +++++++++++++++++++++++++++++-------------- 3 files changed, 217 insertions(+), 109 deletions(-) diff --git a/common/Events.v b/common/Events.v index 5cfe6a837e..5d16509d43 100644 --- a/common/Events.v +++ b/common/Events.v @@ -2193,11 +2193,7 @@ Section VISIBLE. (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_builtin cp name sg | EF_runtime cp name sg => False | EF_inline_asm cp txt sg clb => False | _ => (external_call ef ge args m tr rv m') /\ (tr <> E0) end. diff --git a/riscV/Asm.v b/riscV/Asm.v index dced5744e1..b05efd56ad 100644 --- a/riscV/Asm.v +++ b/riscV/Asm.v @@ -1399,7 +1399,10 @@ 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'). -(* Two fixes: check sig when call CALLSIG, public & first order args when undefined external call ECC *) +(* 3 fixes: +check sig when call CALLSIG, public & +first order args when undefined external call ECC & +builtin result register is only from mreg *) Inductive step_fix: state -> trace -> state -> Prop := | exec_step_fix_internal: forall b ofs f i rs m rs' m' b' ofs' st cp, diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index ecfba1c8fb..ab3b5e5946 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -134,18 +134,18 @@ Section EVENT. Definition typ_to_eventvals (ty: list typ): list eventval := map typ_to_eventval ty. - Inductive call_trace_vr {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> block -> list val -> list typ -> trace -> ident -> list eventval -> Prop := - | call_trace_vr_cross : forall (cp cp' : compartment) (b : block) (vargs : list val) (vl : list eventval) (ty : list typ) (i : ident) tr, + 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_vr ge cp cp' b vargs ty tr i vl. + call_trace_cross ge cp cp' b vargs ty tr i vl. - Inductive return_trace_vr {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> val -> rettype -> trace -> eventval -> Prop := - | return_trace_vr_cross : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype) tr, + 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_vr ge cp cp' v ty tr res. + return_trace_cross ge cp cp' v ty tr res. (* external call *) Definition senv_invert_symbol_total (ge: Senv.t) (b: block) : ident := @@ -201,7 +201,7 @@ Section IR. Definition ir_state := option (block * mem * ir_conts)%type. Variant ir_step (ge: Asm.genv) : ir_state -> bundle_event -> ir_state -> Prop := - | ir_step_vr_call_internal + | ir_step_cross_call_internal cur m1 ik tr id evargs sg cp cp' vargs @@ -213,10 +213,10 @@ Section IR. (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_vr ge cp cp' b vargs (sig_args sg) tr id evargs) + (TR: call_trace_cross ge cp cp' b vargs (sig_args sg) tr id evargs) : ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg None) (Some (b, m1, (ir_cont cur) :: ik)) - | ir_step_vr_return_internal + | ir_step_cross_return_internal cur m1 next ik ik_tl tr evretv cp_cur cp_next vretv @@ -230,7 +230,7 @@ Section IR. 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_vr ge cp_next cp_cur vretv (sig_res sg) tr evretv) + (TR: return_trace_cross ge cp_next cp_cur vretv (sig_res sg) tr evretv) (CONT: ik = (ir_cont next) :: ik_tl) : ir_step ge (Some (cur, m1, ik)) (Bundle_return tr evretv) (Some (next, m1, ik_tl)) @@ -268,7 +268,7 @@ Section IR. (ARGS: evargs = vals_to_eventvals ge vargs) : ir_step ge (Some (cur, m1, ik)) (Bundle_builtin tr ef evargs d) (Some (cur, m2, ik)) - | ir_step_vr_call_external1 + | ir_step_cross_call_external1 (* early cut at call *) cur m1 ik tr id evargs sg @@ -281,7 +281,7 @@ Section IR. (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_vr ge cp cp' b vargs (sig_args sg) tr id evargs) + (TR: call_trace_cross ge cp cp' b vargs (sig_args sg) tr id evargs) : ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg None) None | ir_step_cross_call_external2 @@ -297,7 +297,7 @@ Section IR. (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_vr ge cp cp' b vargs (sig_args sg) tr1 id evargs) + (TR1: call_trace_cross ge cp cp' b vargs (sig_args sg) tr1 id evargs) (* external function part *) d m1' (MEM: mem_delta_apply_inj (meminj_public ge) d (Some m1) = Some m1') @@ -321,7 +321,7 @@ Section IR. (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_vr ge cp cp' b vargs (sig_args sg) tr1 id evargs) + (TR1: call_trace_cross ge cp cp' b vargs (sig_args sg) tr1 id evargs) (* external function part *) d m1' (MEM: mem_delta_apply_inj (meminj_public ge) d (Some m1) = Some m1') @@ -335,7 +335,7 @@ Section IR. (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_vr ge cp cp' vretv (sig_res sg) tr3 evretv) + (TR3: return_trace_cross ge cp cp' vretv (sig_res sg) tr3 evretv) : ir_step ge (Some (cur, m1, ik)) (Bundle_call (tr1 ++ tr2 ++ tr3) id evargs sg (Some d)) (Some (cur, m2, ik)). @@ -629,6 +629,15 @@ Section FROMASM. (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. + End FROMASM. @@ -1340,7 +1349,7 @@ Section PROOF. 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_vr_return_internal. 6: eapply Heq1. all: eauto. + 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. } @@ -1527,6 +1536,106 @@ Section PROOF. } 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). + exploit mem_delta_exec_instr. eapply MEM3. eapply H3. eapply MEM4. eapply MEM5. 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. repeat (split; auto). eapply public_not_freeable_exec_instr. 3: eapply H3. all: auto. eapply meminj_not_alloc_delta; eauto. } + } + 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. + } + 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. (* If main is External, treat it as a different case - the trace can start with Event_syscall, without a preceding Event_call *) @@ -1550,73 +1659,80 @@ Section PROOF. rename H0 into STAR. inv H; simpl. - (** internal *) - 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 H10; inv H10; rewrite NEXTF in H11; inv H11. - } - } - 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). - exploit mem_delta_exec_instr. eapply MEM3. eapply H3. eapply MEM4. eapply MEM5. 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. repeat (split; auto). eapply public_not_freeable_exec_instr. 3: eapply H3. all: auto. eapply meminj_not_alloc_delta; eauto. } - } - exploit IH. 4: eapply STAR. 3: apply WFASM'. 3: eapply MTST'. all: auto. + 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. } - (** has next function --- external *) - { move STAR after NEXTF. inv STAR. - (* end case *) - { end_case. } - (* take a step *) + (* case ccc *) + { destruct ist as [[[cur m_i] ik] |]; ss. + destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). destruct WFASM as [WFASM0 WFASM1]. - exploit asm_to_ir_step_external. 12: eapply H6. 11: eapply NEXTF. 10: eapply NEXTPC. 9: eapply H. all: eauto. - { inv H. - 1,2,3,4: rewrite NEXTPC in H10; inv H10; rewrite NEXTF in H11; inv H11. - rewrite <- REC_CURCOMP. rewrite H10. rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H10; inv H10. 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. - } - 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, H6 into STAR0. - inv STAR'. - { end_case. } - exploit asm_to_ir_returnstate_undef. 2: eapply IH. 12: eapply H6. 11: eapply H. 9: eapply MM'. all: eauto. - { inv STEP0. - 1,2,3,4: rewrite NEXTPC in H10; inv H10; rewrite NEXTF in H11; inv H11. - rewrite <- REC_CURCOMP. rewrite H10. rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H10; inv H10. rewrite <- ALLOWED. - unfold Genv.find_comp. setoid_rewrite H1. auto. + assert (Genv.CrossCompartmentCall <> Genv.InternalCall) by congruence. specialize (CALLSIG H); clear H. des. + exploit exec_instr_is_call; eauto. clear H2 H3 H4. intros (RSX & MEM). subst m'. + 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. } + exists ([Bundle_call [Event_call (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) i0 vl] i0 vl (fn_sig f0) None]). 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. } + } + 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. } - { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } - } + (* 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. inv STAR; ss. + (* subcase 1 *) + { exists ([Bundle_call [Event_call (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) i0 vl] i0 vl (ef_sig e) None]). eexists. ss. split; auto. + econs 2. 2: econs 1. 2: eauto. eapply ir_step_cross_call_external1. + 7: eauto. 6: intros; eapply NO_CROSS_PTR; auto. 5: eapply ALLOWED. all: auto. + { rewrite MTST1. rewrite H0. auto. } + { apply Genv.invert_find_symbol; auto. } + { econs. all: auto. + - replace (comp_of e) with (Genv.find_comp ge (Vptr b0 Ptrofs.zero)); auto. + - replace (comp_of e) with (Genv.find_comp ge (Vptr b0 Ptrofs.zero)); auto. + } + } + rename H into STEP, H2 into STAR. - - (** internal_call *) - (* TODO *) + + (* TODO *) @@ -1647,16 +1763,9 @@ Section PROOF. { split; eauto. } clear dependent btr1. clear dependent m_i. rename m_i' into m_i. destruct WFASM as [WFASM0 WFASM1]. - remember (nextinstr (set_res res vres (undef_regs (map preg_of (destroyed_by_builtin ef)) (rs # X1 <- Vundef) # X31 <- Vundef))) as rs'. - (* FIX - after builtin, compartment can be changed since there is no constraint on next PC. - In fact, Asmgen ensures that res register of builtin is of form (preg_of r), which is never PC ---> augmenting Asm semantics should be possible? - *) + 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. - assert (exists mres, res = (map_builtin_res preg_of mres)). - { admit. (*** FIX *) } - des. subst res. 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. @@ -1934,7 +2043,7 @@ Section PROOF. (* } *) (* { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } *) (* - inv WFIR1. simpl in *. des_ifs. clear H8. unfold wf_ir_cur in WFIR0. des_ifs. clear WFIR0. *) - (* eapply ir_step_vr_return_internal. 6: eapply Heq1. all: eauto. *) + (* eapply ir_step_cross_return_internal. 6: eapply Heq1. all: eauto. *) (* { intros. eapply NO_CROSS_PTR. *) (* rewrite PC_RA, NEXTPC. simpl. rewrite <- COMP. rewrite MTST1 in H. *) (* rewrite <- ALLOWED. rewrite H0 in H. simpl in H. unfold Genv.find_comp at 2 in H. unfold Genv.find_funct in H. des_ifs. *) @@ -2370,23 +2479,23 @@ Section ASMISTEP. Definition genv_invert_symbol_total {F V : Type} (ge : Genv.t F V) : block -> ident := fun b => match Genv.invert_symbol ge b with | Some i => i | None => xH end. - Inductive call_trace_vr {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> val -> list val -> list typ -> trace -> Prop := - call_trace_vr_intra : forall (cp cp' : compartment) (vf : val) (vargs : list val) (ty : list typ), - Genv.type_of_call ge cp cp' = Genv.InternalCall -> call_trace_vr ge cp cp' vf vargs ty E0 - | call_trace_vr_virtual : forall (cp cp' : compartment) (vf : val) (vargs : list val) (vl : list eventval) (ty : list typ) (b : block) (ofs : ptrofs) (i : ident), + Inductive call_trace_cross {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> val -> list val -> list typ -> trace -> Prop := + call_trace_cross_intra : forall (cp cp' : compartment) (vf : val) (vargs : list val) (ty : list typ), + Genv.type_of_call ge cp cp' = Genv.InternalCall -> call_trace_cross ge cp cp' vf vargs ty E0 + | call_trace_cross_virtual : forall (cp cp' : compartment) (vf : val) (vargs : list val) (vl : list eventval) (ty : list typ) (b : block) (ofs : ptrofs) (i : ident), Genv.type_of_call ge cp cp' = Genv.DefaultCompartmentCall -> - vf = Vptr b ofs -> genv_invert_symbol_total ge b = i -> (vl = typ_to_eventvals ty) -> call_trace_vr ge cp cp' vf vargs ty (Event_call cp cp' i vl :: nil) - | call_trace_vr_cross : forall (cp cp' : compartment) (vf : val) (vargs : list val) (vl : list eventval) (ty : list typ) (b : block) (ofs : ptrofs) (i : ident), + vf = Vptr b ofs -> genv_invert_symbol_total ge b = i -> (vl = typ_to_eventvals ty) -> call_trace_cross ge cp cp' vf vargs ty (Event_call cp cp' i vl :: nil) + | call_trace_cross_cross : forall (cp cp' : compartment) (vf : val) (vargs : list val) (vl : list eventval) (ty : list typ) (b : block) (ofs : ptrofs) (i : ident), Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> - vf = Vptr b ofs -> Genv.invert_symbol ge b = Some i -> eventval_list_match ge vl ty vargs -> call_trace_vr ge cp cp' vf vargs ty (Event_call cp cp' i vl :: nil). + vf = Vptr b ofs -> Genv.invert_symbol ge b = Some i -> eventval_list_match ge vl ty vargs -> call_trace_cross ge cp cp' vf vargs ty (Event_call cp cp' i vl :: nil). - Inductive return_trace_vr {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> val -> rettype -> trace -> Prop := - return_trace_vr_intra : forall (cp cp' : compartment) (v : val) (ty : rettype), - Genv.type_of_call ge cp cp' = Genv.InternalCall -> return_trace_vr ge cp cp' v ty E0 - | return_trace_vr_virtual : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype), - Genv.type_of_call ge cp cp' = Genv.DefaultCompartmentCall -> (res = typ_to_eventval (proj_rettype ty)) -> return_trace_vr ge cp cp' v ty (Event_return cp cp' res :: nil) - | return_trace_vr_cross : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype), - Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> eventval_match ge res (proj_rettype ty) v -> return_trace_vr ge cp cp' v ty (Event_return cp cp' res :: nil). + Inductive return_trace_cross {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> val -> rettype -> trace -> Prop := + return_trace_cross_intra : forall (cp cp' : compartment) (v : val) (ty : rettype), + Genv.type_of_call ge cp cp' = Genv.InternalCall -> return_trace_cross ge cp cp' v ty E0 + | return_trace_cross_virtual : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype), + Genv.type_of_call ge cp cp' = Genv.DefaultCompartmentCall -> (res = typ_to_eventval (proj_rettype ty)) -> return_trace_cross ge cp cp' v ty (Event_return cp cp' res :: nil) + | return_trace_cross_cross : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype), + Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> eventval_match ge res (proj_rettype ty) v -> return_trace_cross ge cp cp' v ty (Event_return cp cp' res :: nil). Variant asm_istep: state -> itrace -> state -> Prop := | exec_asm_istep_internal: @@ -2418,7 +2527,7 @@ Section ASMISTEP. 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_vr ge (comp_of f) (Genv.find_comp_ignore_offset ge (Vptr b' ofs')) (Vptr b' ofs') + forall (EV: call_trace_cross ge (comp_of f) (Genv.find_comp_ignore_offset ge (Vptr b' ofs')) (Vptr b' ofs') args (sig_args sig) t), forall (INFO: let ce := match (Genv.find_funct_ptr ge b', (comp_of f) =? (Genv.find_comp_ignore_offset ge (Vptr b' ofs'))) with | (Some (External ef), false) => is_cross_ext @@ -2466,7 +2575,7 @@ Section ASMISTEP. forall (NO_CROSS_PTR: (Genv.type_of_call ge cp' rec_cp = Genv.CrossCompartmentCall -> not_ptr (return_value rs sg))), - forall (EV: return_trace_vr ge cp' rec_cp (return_value rs sg) (sig_res sg) t), + forall (EV: return_trace_cross ge cp' rec_cp (return_value rs sg) (sig_res sg) t), forall (INFO: let vr := match Genv.type_of_call ge cp' rec_cp with | Genv.DefaultCompartmentCall => is_virtual | _ => is_real From 299d1eeb1e17d2b36c0d50e79483091b3cbaf121 Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 31 Jul 2023 19:16:05 +0200 Subject: [PATCH 093/174] WIP --- security/BtInfoAsm.v | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index ab3b5e5946..932877d526 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -912,12 +912,6 @@ Section PROOF. - (* extcall is known and observable *) rename H4 into EXTCALL, H7 into EXTARGS. unfold external_call_known_observables in ECKO. des_ifs; simpl in *. - { 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: split; 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: split; auto. 2: eauto. econstructor 1. - } { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. exists ([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 |} (Some [])]). exists k, d, m_a0, m_i, m'. simpl. splits; auto. 2: split; auto. 2: eauto. @@ -1093,12 +1087,6 @@ Section PROOF. - (* extcall is known and observable *) unfold external_call_known_observables in ECKO. des_ifs; simpl in *. - { unfold builtin_or_external_sem in EXTCALL. rewrite Heq in EXTCALL. inv EXTCALL. - exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: split; 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: split; auto. econstructor 1. - } { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. exists ([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. From 15b8641237f25b73f4d2efc2ce9321d1bb16db8f Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 1 Aug 2023 16:00:41 +0200 Subject: [PATCH 094/174] WIP --- need to add more clases and instances for is_external class --- cfrontend/Csem.v | 27 ++++++++++++ common/AST.v | 27 ++++++++++++ common/Events.v | 27 ++++++++++++ common/Globalenvs.v | 97 +++++++++++++++++++++++++++----------------- security/BtInfoAsm.v | 31 +++++++++++++- 5 files changed, 170 insertions(+), 39 deletions(-) diff --git a/cfrontend/Csem.v b/cfrontend/Csem.v index 9e12ed4353..cc3ce18dc6 100644 --- a/cfrontend/Csem.v +++ b/cfrontend/Csem.v @@ -884,3 +884,30 @@ Proof. inv H; simpl; try lia. eapply external_call_trace_length; eauto. inv EV; simpl; try lia. Qed. + +Global Instance is_external_fundef_ctypes : is_external (fundef) := + { 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 kind cp txt targs => cp = cp' + end + end + }. diff --git a/common/AST.v b/common/AST.v index d821e560be..becbb29617 100644 --- a/common/AST.v +++ b/common/AST.v @@ -792,6 +792,33 @@ 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_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. + (** 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 5d16509d43..ac75450ce0 100644 --- a/common/Events.v +++ b/common/Events.v @@ -2233,3 +2233,30 @@ Section VISIBLE. (* end. *) End VISIBLE. + +Global Instance is_external_fundef 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 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 kind cp txt targs => cp = cp' + end + end + }. diff --git a/common/Globalenvs.v b/common/Globalenvs.v index 122808db81..be187c854e 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. diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 932877d526..1ce96b28a4 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -339,6 +339,35 @@ Section IR. : ir_step ge (Some (cur, m1, ik)) (Bundle_call (tr1 ++ tr2 ++ tr3) id evargs sg (Some d)) (Some (cur, m2, ik)). + + 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. + +external_call = +fun ef : external_function => +match ef with +| EF_builtin _ name sg | EF_runtime _ name sg => builtin_or_external_sem name sg +| EF_vload cp chunk => volatile_load_sem cp chunk +| EF_vstore cp chunk => volatile_store_sem cp chunk +| EF_malloc cp => extcall_malloc_sem cp +| EF_free cp => extcall_free_sem cp +| EF_memcpy cp sz al => extcall_memcpy_sem cp sz al +| EF_debug _ cp _ _ => extcall_debug_sem cp +end + : external_function -> extcall_sem + End IR. @@ -1720,7 +1749,7 @@ Section PROOF. rename H into STEP, H2 into STAR. - (* TODO *) + (*** TODO *) From 64fea52ae2215cae7fe4cbe50fa8ea87bbc7f169 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9my=20Thibault?= Date: Tue, 1 Aug 2023 17:43:06 +0200 Subject: [PATCH 095/174] Implements instances of is_external, etc. everywhere --- backend/Allocproof.v | 15 +++++++++ backend/CSEproof.v | 10 ++++++ backend/CleanupLabelsproof.v | 3 ++ backend/Constpropproof.v | 3 ++ backend/Deadcodeproof.v | 9 ++++++ backend/Debugvarproof.v | 8 +++++ backend/Inliningproof.v | 11 +++++++ backend/Linearizeproof.v | 6 ++++ backend/RTLgenproof.v | 9 ++++++ backend/Renumberproof.v | 3 ++ backend/Selectionproof.v | 5 +++ backend/Stackingproof.v | 6 ++++ backend/Tailcallproof.v | 6 ++++ backend/Tunnelingproof.v | 3 ++ backend/Unusedglobproof.v | 20 ++++++++---- cfrontend/Cminorgenproof.v | 10 ++++++ cfrontend/Csem.v | 26 ---------------- cfrontend/Cshmgenproof.v | 5 +++ cfrontend/Csyntax.v | 3 +- cfrontend/Ctypes.v | 59 +++++++++++++++++++++++++++++++++++- cfrontend/SimplExprproof.v | 7 +++++ cfrontend/SimplLocalsproof.v | 5 +++ common/AST.v | 37 ++++++++++++++++++++-- common/Events.v | 34 +++++++++++++++++++-- common/Globalenvs.v | 2 ++ riscV/Asmgenproof.v | 8 +++++ 26 files changed, 275 insertions(+), 38 deletions(-) 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 cc3ce18dc6..2daaf81c9b 100644 --- a/cfrontend/Csem.v +++ b/cfrontend/Csem.v @@ -885,29 +885,3 @@ Proof. inv EV; simpl; try lia. Qed. -Global Instance is_external_fundef_ctypes : is_external (fundef) := - { 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 kind cp txt targs => cp = cp' - end - end - }. 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..794d97c874 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 kind cp 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 kind cp 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 becbb29617..bd0cf57b83 100644 --- a/common/AST.v +++ b/common/AST.v @@ -803,9 +803,22 @@ Class is_external_match {C T S: Type} {ET: is_external T} {ES: is_external S} 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) := + {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. @@ -819,6 +832,26 @@ 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 ac75450ce0..3ec18b4edf 100644 --- a/common/Events.v +++ b/common/Events.v @@ -2234,7 +2234,7 @@ Section VISIBLE. End VISIBLE. -Global Instance is_external_fundef F : is_external (fundef F) := +Global Program Instance is_external_fundef (F: Type) : is_external (fundef F) := { is_ok := fun cp' fd => match fd with @@ -2258,5 +2258,35 @@ Global Instance is_external_fundef F : is_external (fundef F) := | EF_inline_asm cp txt sg clb => True | EF_debug kind cp txt targs => cp = cp' end - 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 kind cp 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 be187c854e..6e754bf0a1 100644 --- a/common/Globalenvs.v +++ b/common/Globalenvs.v @@ -2522,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/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. From 1ebf6344a16bb64bc882b5f268f7ae9e2a529cd4 Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 1 Aug 2023 18:11:27 +0200 Subject: [PATCH 096/174] WIP --- security/BtInfoAsm.v | 29 ----------------------------- 1 file changed, 29 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 1ce96b28a4..28cff2a35d 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -339,35 +339,6 @@ Section IR. : ir_step ge (Some (cur, m1, ik)) (Bundle_call (tr1 ++ tr2 ++ tr3) id evargs sg (Some d)) (Some (cur, m2, ik)). - - 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. - -external_call = -fun ef : external_function => -match ef with -| EF_builtin _ name sg | EF_runtime _ name sg => builtin_or_external_sem name sg -| EF_vload cp chunk => volatile_load_sem cp chunk -| EF_vstore cp chunk => volatile_store_sem cp chunk -| EF_malloc cp => extcall_malloc_sem cp -| EF_free cp => extcall_free_sem cp -| EF_memcpy cp sz al => extcall_memcpy_sem cp sz al -| EF_debug _ cp _ _ => extcall_debug_sem cp -end - : external_function -> extcall_sem - End IR. From 243742b1bc85a27a8e6111a38514aca59622acc7 Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 2 Aug 2023 14:28:03 +0200 Subject: [PATCH 097/174] WIP --- security/BtInfoAsm.v | 65 ++++++++++++++++++++++++++++++++++++++------ 1 file changed, 56 insertions(+), 9 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 28cff2a35d..58d46398c7 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -1625,6 +1625,48 @@ Section PROOF. } 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. + (* 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 @@ -1705,19 +1747,24 @@ Section PROOF. { 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. inv STAR; ss. + 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 ([Bundle_call [Event_call (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) i0 vl] i0 vl (ef_sig e) None]). eexists. ss. split; auto. econs 2. 2: econs 1. 2: eauto. eapply ir_step_cross_call_external1. - 7: eauto. 6: intros; eapply NO_CROSS_PTR; auto. 5: eapply ALLOWED. all: auto. - { rewrite MTST1. rewrite H0. auto. } - { apply Genv.invert_find_symbol; auto. } - { econs. all: auto. - - replace (comp_of e) with (Genv.find_comp ge (Vptr b0 Ptrofs.zero)); auto. - - replace (comp_of e) with (Genv.find_comp ge (Vptr b0 Ptrofs.zero)); auto. - } + 8: eapply FACT8. 6: eapply FACT6. 5: eapply FACT5. 3: eapply FACT3. 2: eapply FACT2. all: eauto. } - rename H into STEP, H2 into STAR. + 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. + + inv STAR. + (* subcase 2 *) + { + + (*** TODO *) From ca5fa46bd9196ce8df56f001bcfe240ea8219817 Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 2 Aug 2023 18:56:37 +0200 Subject: [PATCH 098/174] WIP; also some minor fixes --- cfrontend/Ctypes.v | 4 +- common/Events.v | 6 +- security/BtInfoAsm.v | 303 ++++++++++++++++++++++++++++++++++--------- 3 files changed, 248 insertions(+), 65 deletions(-) diff --git a/cfrontend/Ctypes.v b/cfrontend/Ctypes.v index 794d97c874..492f530827 100644 --- a/cfrontend/Ctypes.v +++ b/cfrontend/Ctypes.v @@ -2044,7 +2044,7 @@ Global Program Instance is_external_fundef_ctypes f : is_external (fundef f) := | 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 kind cp txt targs => cp = cp' + | EF_debug cp kind txt targs => cp = cp' end end; is_ok_b := @@ -2068,7 +2068,7 @@ Global Program Instance is_external_fundef_ctypes f : is_external (fundef f) := | 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 kind cp txt targs => Pos.eqb cp cp' + | EF_debug cp kind txt targs => Pos.eqb cp cp' end end; is_ok_reflect := _; diff --git a/common/Events.v b/common/Events.v index 3ec18b4edf..dee05bf981 100644 --- a/common/Events.v +++ b/common/Events.v @@ -1666,7 +1666,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 := @@ -2256,7 +2256,7 @@ Global Program Instance is_external_fundef (F: Type) : is_external (fundef F) := | 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 kind cp txt targs => cp = cp' + | EF_debug cp kind txt targs => cp = cp' end end; is_ok_b := @@ -2280,7 +2280,7 @@ Global Program Instance is_external_fundef (F: Type) : is_external (fundef F) := | 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 kind cp txt targs => Pos.eqb cp cp' + | EF_debug cp kind txt targs => Pos.eqb cp cp' end end; is_ok_reflect := _; diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 58d46398c7..3af996f921 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -830,6 +830,129 @@ Section PROOF. exists btr, ist'. split; auto. Qed. + Lemma match_mem_external_call_establish1 + (ge: genv) k d m_a0 m_i m + (MEM: match_mem ge 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_inj (meminj_public ge) 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 k2 [] m' m2 m') + . + Proof. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5). + (* reestablish meminj *) + exploit mem_delta_apply_establish_inject; eauto. + { apply meminj_public_strict. } + { admit. (* ECU *) } + intros (m_i' & APPD' & MEMINJ'). hexploit external_call_mem_inject. 2: eapply EXTCALL. all: eauto. + { admit. (* ez *) } + { instantiate (1:=args). admit. } + intros (f' & vres' & m_i'' & EXTCALL' & VALINJ' & MEMINJ'' & _ & _ & INCRINJ' & _). + assert (MM': match_mem ge f' [] m' m_i'' m'). + { unfold match_mem. simpl. splits; auto. + { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. + 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. + } + { 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. + } + constructor. + } + exists m_i', m_i'', vres'. splits; eauto. + { clear - ECC MEMINJ'. admit. (* visible_fo *) } + Admitted. + + Lemma match_mem_external_call_establish2 + ge k d m_a0 m_i m + (MEM: match_mem ge 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 k d m_a0 m_i m') + . + (* exists d' m1 m2 res', *) + (* (mem_delta_apply_inj (meminj_public ge) d' (Some m_i) = Some m1) /\ *) + (* (external_call ef ge args m1 t res' m2) /\ *) + (* (external_call_known_observables ef ge m1 args t res' m2) /\ *) + (* (exists k2 d2 m_a02 m_i2, match_mem ge k2 d2 m_a02 m_i2 m') *) + (* . *) + Proof. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5). + 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. split; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. esplits; eauto. + 1,2: econs; econs; eauto. split; 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. split; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL. esplits; eauto. + 1,2: econs; eauto. split; auto. + } + { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } + Qed. + (* destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5). *) + (* unfold external_call_known_observables in ECKO. *) + (* des_ifs; simpl in *. *) + (* { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. exists []. esplits; eauto. 4: unfold match_mem; splits; eauto. *) + (* simpl. eauto. 1,2: econs; econs; eauto. *) + (* } *) + (* { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. exists []. esplits; eauto. 4: unfold match_mem; splits; eauto. *) + (* simpl. eauto. 1,2: econs; econs; eauto. *) + (* } *) + (* { 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. exists []. esplits; eauto. 4: unfold match_mem; splits; eauto. *) + (* simpl. eauto. 1,2: econs; eauto. *) + (* } *) + (* { destruct ECKO as [_ OBS]. inv EXTCALL. exists []. esplits; eauto. 4: unfold match_mem; splits; eauto. *) + (* simpl. eauto. 1,2: econs; eauto. *) + (* } *) + (* { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } *) + (* Qed. *) + + Lemma match_mem_external_call_establish + (ge: genv) k d m_a0 m_i m + (MEM: match_mem ge 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_inj (meminj_public ge) 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)) /\ + (exists k2 d2 m_a02 m_i2, match_mem ge k2 d2 m_a02 m_i2 m') + . + 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. instantiate (1:=[]); ss. + Qed. + Lemma asm_to_ir_step_external cpm (ge: genv) (WFGE: wf_ge ge) @@ -849,7 +972,6 @@ Section PROOF. (NEXTPC: rs PC = Vptr b1 ofs1) ef (NEXTF : Genv.find_funct_ptr ge b1 = Some (External ef)) - (* STEP : step_fix cpm ge (State st rs m_a) t1 s2 *) n t' ast'' (STAR: star_measure (step_fix cpm) ge n ast' t' ast'') : @@ -872,42 +994,52 @@ Section PROOF. exploit extcall_cases. eapply ECC. eauto. clear ECC. intros [ECU | [ECKO | ECKS]]. - (* extcall is unknown *) - (* reestablish meminj *) - exploit mem_delta_apply_establish_inject; eauto. - { admit. (* ez *) } - { admit. (* ECU *) } - intros (m_i' & APPD' & MEMINJ'). exploit external_call_mem_inject; eauto. - { admit. (* ez *) } - { instantiate (1:=args). admit. } - intros (f' & vres' & m_i'' & EXTCALL' & VALINJ' & MEMINJ'' & _ & _ & INCRINJ' & _). - assert (MM': match_mem ge f' [] m' m_i'' m'). - { unfold match_mem. simpl. split; auto. split; auto. split. - { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. - clear - H4 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. - pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H4). - destruct (Pos.leb_spec (Mem.nextblock m_a) b); auto. - unfold Mem.valid_block in H0. apply H0 in H1. exfalso. unfold Plt in H1. lia. - } - split. - { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. - clear - H4 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_a)); auto. - specialize (NALLOC _ H0). congruence. - } - split; auto. constructor. - } + exploit match_mem_external_call_establish1; eauto. unfold match_mem; splits; eauto. + intros. des. exists ([Bundle_call t ef_id (vals_to_eventvals ge args) (ef_sig ef0) (Some d)]). - do 5 eexists. splits; simpl. 3: eapply MM'. apply app_nil_r. + 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. } - { clear - ECU MEMINJ'. left. admit. (* TODO *) } + (* reestablish meminj *) + (* exploit mem_delta_apply_establish_inject; eauto. *) + (* { admit. (* ez *) } *) + (* { admit. (* ECU *) } *) + (* intros (m_i' & APPD' & MEMINJ'). exploit external_call_mem_inject; eauto. *) + (* { admit. (* ez *) } *) + (* { instantiate (1:=args). admit. } *) + (* intros (f' & vres' & m_i'' & EXTCALL' & VALINJ' & MEMINJ'' & _ & _ & INCRINJ' & _). *) + (* assert (MM': match_mem ge f' [] m' m_i'' m'). *) + (* { unfold match_mem. simpl. split; auto. split; auto. split. *) + (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. *) + (* clear - H4 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. *) + (* pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H4). *) + (* destruct (Pos.leb_spec (Mem.nextblock m_a) b); auto. *) + (* unfold Mem.valid_block in H0. apply H0 in H1. exfalso. unfold Plt in H1. lia. *) + (* } *) + (* split. *) + (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. *) + (* clear - H4 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_a)); auto. *) + (* specialize (NALLOC _ H0). congruence. *) + (* } *) + (* split; auto. constructor. *) + (* } *) + (* exists ([Bundle_call t ef_id (vals_to_eventvals ge args) (ef_sig ef0) (Some d)]). *) + (* do 5 eexists. splits; simpl. 3: eapply MM'. 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. *) + (* } *) + (* { clear - ECU MEMINJ'. left. admit. (* TODO *) } *) - (* extcall is known and observable *) rename H4 into EXTCALL, H7 into EXTARGS. unfold external_call_known_observables in ECKO. @@ -1052,37 +1184,43 @@ Section PROOF. exploit extcall_cases. eapply ECC. eauto. clear ECC. intros [ECU | [ECKO | ECKS]]. - (* extcall is unknown *) - (* reestablish meminj *) - exploit mem_delta_apply_establish_inject; eauto. - { admit. (* ez *) } - { admit. (* ECU *) } - intros (m_i' & APPD' & MEMINJ'). exploit external_call_mem_inject; eauto. - { admit. (* ez *) } - { instantiate (1:=vargs). admit. } - intros (f' & vres' & m_i'' & EXTCALL' & VALINJ' & MEMINJ'' & _ & _ & INCRINJ' & _). - assert (MM': match_mem ge f' [] m' m_i'' m'). - { unfold match_mem. simpl. splits; auto. - { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. - 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. - } - { 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. - } - constructor. - } + exploit match_mem_external_call_establish1; eauto. unfold match_mem; splits; eauto. + intros. des. exists ([Bundle_builtin t1 ef (vals_to_eventvals ge vargs) d]). - do 4 eexists. splits; simpl. 3: eapply MM'. apply app_nil_r. + do 4 eexists. splits; simpl. 3: eapply x3. apply app_nil_r. econstructor 2. 2: econstructor 1. 2: eauto. eapply ir_step_builtin; eauto. - { clear - ECU MEMINJ'. left. admit. (* TODO *) } + (* reestablish meminj *) + (* exploit mem_delta_apply_establish_inject; eauto. *) + (* { admit. (* ez *) } *) + (* { admit. (* ECU *) } *) + (* intros (m_i' & APPD' & MEMINJ'). exploit external_call_mem_inject; eauto. *) + (* { admit. (* ez *) } *) + (* { instantiate (1:=vargs). admit. } *) + (* intros (f' & vres' & m_i'' & EXTCALL' & VALINJ' & MEMINJ'' & _ & _ & INCRINJ' & _). *) + (* assert (MM': match_mem ge f' [] m' m_i'' m'). *) + (* { unfold match_mem. simpl. splits; auto. *) + (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. *) + (* 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. *) + (* } *) + (* { 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. *) + (* } *) + (* constructor. *) + (* } *) + (* exists ([Bundle_builtin t1 ef (vals_to_eventvals ge vargs) d]). *) + (* do 4 eexists. splits; simpl. 3: eapply MM'. apply app_nil_r. *) + (* econstructor 2. 2: econstructor 1. 2: eauto. *) + (* eapply ir_step_builtin; eauto. *) + (* { clear - ECU MEMINJ'. left. admit. (* TODO *) } *) - (* extcall is known and observable *) unfold external_call_known_observables in ECKO. @@ -1667,6 +1805,34 @@ Section PROOF. 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 @@ -1759,10 +1925,27 @@ Section PROOF. 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 & m_i2 & MM)). inv STAR. (* subcase 2 *) - { + { exists ([Bundle_call ([Event_call (comp_of f) (Genv.find_comp ge (Vptr b2 Ptrofs.zero)) i0 vl] ++ t1) i0 vl (ef_sig ef) (Some 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. From 8704e9f0bd5b6902f8dba641fb0eb237152fe85f Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 3 Aug 2023 14:42:47 +0200 Subject: [PATCH 099/174] WIP --- security/BtInfoAsm.v | 1062 ++---------------------------------------- 1 file changed, 49 insertions(+), 1013 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 3af996f921..56f36c8a90 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -841,7 +841,7 @@ Section PROOF. (mem_delta_apply_inj (meminj_public ge) 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 k2 [] m' m2 m') + (exists k2, match_mem ge k2 [] m' m2 m' /\ Val.inject k2 res res') . Proof. destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5). @@ -886,18 +886,12 @@ Section PROOF. (external_call_known_observables ef ge m_i args t res m_i) /\ (match_mem ge k d m_a0 m_i m') . - (* exists d' m1 m2 res', *) - (* (mem_delta_apply_inj (meminj_public ge) d' (Some m_i) = Some m1) /\ *) - (* (external_call ef ge args m1 t res' m2) /\ *) - (* (external_call_known_observables ef ge m1 args t res' m2) /\ *) - (* (exists k2 d2 m_a02 m_i2, match_mem ge k2 d2 m_a02 m_i2 m') *) - (* . *) Proof. destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5). 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. split; auto. + 1,2: econs; econs; eauto. split; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. esplits; eauto. 1,2: econs; econs; eauto. split; auto. @@ -945,7 +939,7 @@ Section PROOF. (mem_delta_apply_inj (meminj_public ge) 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)) /\ - (exists k2 d2 m_a02 m_i2, match_mem ge k2 d2 m_a02 m_i2 m') + (exists k2 d2 m_a02, match_mem ge k2 d2 m_a02 m2 m' /\ (Val.inject k2 res res' \/ (res = res'))) . Proof. destruct ECC as [ECC | ECC]. @@ -1937,7 +1931,7 @@ Section PROOF. } 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 & m_i2 & MM)). + destruct x0 as (d' & m1 & m2 & res' & EFACT1 & EFACT2 & EFACT3 & (k2 & d2 & m_a02 & MM)). inv STAR. (* subcase 2 *) { exists ([Bundle_call ([Event_call (comp_of f) (Genv.find_comp ge (Vptr b2 Ptrofs.zero)) i0 vl] ++ t1) i0 vl (ef_sig ef) (Some d')]). eexists. split; auto. @@ -1945,16 +1939,50 @@ Section PROOF. 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. - - - - - (*** TODO *) - - - - admit. + 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 ([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) (Some 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. @@ -1999,998 +2027,6 @@ Section PROOF. exfalso. destruct WFASM as [WFASM0 WFASM1]. unfold wf_regset in WFASM1. rewrite H0 in WFASM1. rewrite H1 in WFASM1. contradiction WFASM1. - - Abort. - - - - - - - inv H; simpl in *; try rewrite Pregmap.gss in *. inv EV. - 2:{ ex - rewrite <- REC_CURCOMP. rewrite H10. rewrite MTST1, H0. simpl in *. rewrite NEXTPC in H10; inv H10. rewrite <- ALLOWED. - unfold Genv.find_comp. setoid_rewrite H1. auto. - } - { - - inv H. - (* invalid *) - 1,2,3,4: rewrite NEXTPC in H10; inv H10; rewrite NEXTF in H11; inv H11. - (** external & InternalCall *) - rewrite NEXTPC in H10; inv H10. rewrite NEXTF in H11; inv H11. - 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; eauto. intros FINDSYMB. clear TEMP. - (* reestablish meminj *) - exploit mem_delta_apply_establish_inject. eapply MEM0. eapply MEM1. - { admit. (* ez *) } - eapply MEM2. eapply MEM4'. eapply MEM5'. - { admit. (* use VISFO *) } - intros (m1' & MEMAPPIR & MEMINJ'). - exploit external_call_mem_inject. - 2:{ eapply H12. } - 2:{ eapply MEMINJ'. } - { admit. } - { instantiate (1:=args). admit. } - intros (f' & vres' & m2' & EXTCALL' & VALINJ' & MEMINJ'2 & _ & _ & INCRINJ & _). - (* take a step *) - rename H6 into STAR; move STAR after REC_CURCOMP. inv STAR. - (* end case *) - { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')]). eexists. simpl. split; auto. - econstructor 2. 2: econstructor 1. 2: auto. - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. - { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. - rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. - unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. - } - { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } - } - - destruct WFASM as [WFASM0 WFASM1]. - exploit asm_to_ir_returnstate_undef. 2: eapply IH. 11: eapply H. 11: eapply H6. all: auto. 1,2,3: eauto. all: auto. - { unfold match_cur_regset in *. simpl in *. rewrite <- REC_CURCOMP. rewrite NEXTPC. simpl. rewrite <- ALLOWED. - rewrite MTST1, H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite H1. auto. - } - { instantiate (4:=f'). instantiate (3:=[]). instantiate (2:=m'0). instantiate (1:=m2'). unfold match_mem. simpl. split; auto. split; auto. split. - { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. - pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. - } - split. - { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. pose proof (public_not_freeable_exec_instr _ _ _ _ _ _ _ _ MEM3 NALLOC H3) as NFREE. - pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC2. - clear - H12 NFREE NALLOC2. unfold public_not_freeable in *. intros. specialize (NFREE _ H). intros CC. apply NFREE; clear NFREE. - eapply external_call_max_perm; eauto. unfold Mem.valid_block. unfold meminj_not_alloc in NALLOC2. - unfold Plt. destruct (Pos.ltb_spec b (Mem.nextblock m')); auto. specialize (NALLOC2 _ H0). congruence. - } - split; auto. constructor. - } - { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } - intros (btr & ist' & UTR & ISTAR). - exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')] ++ btr), ist'. simpl. rewrite UTR. split; auto. - econstructor 2. 2: eapply ISTAR. 2: auto. - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. - { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. - rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. - unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. - } - { admit. (* FIX: at exists, if knowns, empty event, unknown case uses VISFO --- case analysis first on unknowns? *) } - } - - - (* (** steps --- ReturnState *) *) - (* inv H. inv EV; simpl in *. *) - (* (** return is nccc *) *) - (* { rename H6 into STAR, H into NCCC. rewrite Pregmap.gss in H13, PC_RA, RESTORE_SP, NO_CROSS_PTR, NCCC. *) - (* pose proof STAR as STAR0. inv STAR. *) - (* (* end case *) *) - (* { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')]). simpl. eexists. split; auto. *) - (* econstructor 2. 2: econstructor 1. 2: auto. *) - (* eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. *) - (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) - (* rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. *) - (* unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. *) - (* } *) - (* { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } *) - (* } *) - (* (* has next step - if internal, done; if external, ub *) *) - (* rename H into STEP, H6 into STAR. destruct (rs' X1) eqn:NEXTPC2. *) - (* 1,2,3,4,5: inv STEP; rewrite Pregmap.gss in H8; inv H8. (* make a lemma *) *) - (* destruct (Genv.find_funct_ptr ge b1) eqn:NEXTF2. *) - (* 2:{ inv STEP; rewrite Pregmap.gss in H8; inv H8; rewrite NEXTF2 in H9; inv H9. (* make a lemma *) } *) - (* destruct f0. *) - (* (** next is internal *) *) - (* { exploit IH; clear IH. 4: eapply STAR0. lia. all: auto. *) - (* { simpl. destruct WFASM as [WFASM1 WFASM2]. split. *) - (* - unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pregmap.gss in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. *) - (* - unfold wf_regset in *. rewrite Pregmap.gss. rewrite NEXTF2. auto. *) - (* } *) - (* { instantiate (1:=Some (cur, m2', ik)). simpl. split; auto. split; auto. split. *) - (* { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pregmap.gss in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } *) - (* split. *) - (* { unfold match_cur_regset in *. rewrite Pregmap.gss. simpl in *. unfold Genv.type_of_call in NCCC. des_ifs. *) - (* rewrite MTST1. rewrite H0; simpl. apply Pos.eqb_eq in Heq. rewrite Heq. rewrite <- REC_CURCOMP. rewrite NEXTPC. simpl. rewrite <- ALLOWED. *) - (* unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite H1. auto. *) - (* } *) - (* split. *) - (* { unfold Genv.type_of_call in NCCC. des_ifs. unfold update_stack_return in STUPD. rewrite Pregmap.gss in STUPD. rewrite Pos.eqb_sym, Heq in STUPD. inv STUPD. auto. } *) - (* { instantiate (3:=f'). instantiate (2:=[]). instantiate (1:=m'0). unfold match_mem. simpl. split; auto. split; auto. split. *) - (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. *) - (* pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. *) - (* } *) - (* split. *) - (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. pose proof (public_not_freeable_exec_instr _ _ _ _ _ _ _ _ MEM3 NALLOC H3) as NFREE. *) - (* pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC2. *) - (* clear - H12 NFREE NALLOC2. unfold public_not_freeable in *. intros. specialize (NFREE _ H). intros CC. apply NFREE; clear NFREE. *) - (* eapply external_call_max_perm; eauto. unfold Mem.valid_block. unfold meminj_not_alloc in NALLOC2. *) - (* unfold Plt. destruct (Pos.ltb_spec b (Mem.nextblock m')); auto. specialize (NALLOC2 _ H0). congruence. *) - (* } *) - (* split; auto. constructor. *) - (* } *) - (* } *) - (* intros (btr & ist' & UTR & ISTAR'). *) - (* (* FIX: case analysis on whether extcall is unknown or not *) *) - (* exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')] ++ btr), ist'. simpl. rewrite UTR. split; auto. *) - (* econstructor 2. 2: eapply ISTAR'. 2: auto. *) - (* eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. *) - (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) - (* rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. *) - (* unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. *) - (* } *) - (* { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } *) - (* } *) - - (* (** next is external --- another extcall, Returnstate, and finally next-next PC is Vundef *) *) - (* (* take a step *) *) - (* inv STEP. *) - (* (* invalid *) *) - (* 1,2,3,4: rewrite Pregmap.gss in H8; inv H8; rewrite NEXTF2 in H9; inv H9. *) - (* (** external & InternalCall & next PC is Vundef *) *) - (* rewrite Pregmap.gss in H8; inv H8. rewrite NEXTF2 in H9; inv H9. *) - (* assert (STUCK: ((set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (Vptr b2 Ptrofs.zero) X1) = Vundef). *) - (* { clear. rewrite Pregmap.gso. 2: congruence. unfold loc_external_result. unfold Conventions1.loc_result. des_ifs. } *) - (* rewrite STUCK in STAR. *) - (* exploit Genv.find_funct_ptr_iff. intros (TEMP & _). specialize (TEMP NEXTF2). exploit wf_ge_block_to_id; eauto. intros (ef_id2 & INVSYMB2). *) - (* exploit Genv.invert_find_symbol. eapply INVSYMB2. intros FINDSYMB2. clear TEMP. *) - (* (* reestablish meminj *) *) - (* exploit mem_delta_apply_establish_inject. eapply MEMINJ'2. eapply INCRINJ. *) - (* { admit. (* ez *) } *) - (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. *) - (* pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. *) - (* } *) - (* { econstructor 1. } *) - (* { simpl; eauto. } *) - (* { admit. (* VISFO0, FIX - unknown or not *) } *) - (* simpl. intros (m3' & TEMPEQ & MEMINJ''). symmetry in TEMPEQ. inv TEMPEQ. *) - (* exploit external_call_mem_inject. *) - (* 2:{ eapply H10. } *) - (* 2:{ eapply MEMINJ''. } *) - (* { admit. } *) - (* { instantiate (1:=args0). admit. } *) - (* intros (f'' & vres'' & m3' & EXTCALL'' & VALINJ'' & MEMINJ'3 & _ & _ & INCRINJ'' & _). *) - (* inv STAR. *) - (* (* end case *) *) - (* { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d'); Bundle_call t0 ef_id2 (vals_to_eventvals ge args0) (ef_sig ef0) (Some [])]). simpl. *) - (* eexists. split; auto. econstructor 2. 2: econstructor 2. 3: econstructor 1. 3,4: eauto. *) - (* - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. *) - (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) - (* rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. *) - (* unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. *) - (* } *) - (* { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } *) - (* - eapply ir_step_intra_call_external. 2: eapply FINDSYMB2. 2: eapply NEXTF2. 6: eapply EXTCALL''. all: eauto. *) - (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) - (* rewrite H1. setoid_rewrite ALLOWED. rewrite NEXTPC in REC_CURCOMP; simpl in *. rewrite REC_CURCOMP. *) - (* unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. rewrite <- Heq. unfold Genv.find_comp, Genv.find_funct. des_ifs. *) - (* unfold Genv.type_of_call. unfold comp_of at 1. simpl. rewrite Pos.eqb_refl; auto. *) - (* } *) - (* { admit. (* fix? VISFO0 --- maybe case analysis first on unknowns? *) } *) - (* } *) - (* inv H; simpl in *. rewrite Pregmap.gss in *. inv H6. *) - (* (* end case *) *) - (* { inv EV. *) - (* (* return is NCCC - silent *) *) - (* { exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d'); Bundle_call t0 ef_id2 (vals_to_eventvals ge args0) (ef_sig ef0) (Some [])]). simpl. *) - (* eexists. split; auto. econstructor 2. 2: econstructor 2. 3: econstructor 1. 3,4: eauto. *) - (* - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. *) - (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) - (* rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. *) - (* unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. *) - (* } *) - (* { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } *) - (* - eapply ir_step_intra_call_external. 2: eapply FINDSYMB2. 2: eapply NEXTF2. 6: eapply EXTCALL''. all: eauto. *) - (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) - (* rewrite H1. setoid_rewrite ALLOWED. rewrite NEXTPC in REC_CURCOMP; simpl in *. rewrite REC_CURCOMP. *) - (* unfold Genv.type_of_call in NCCC. des_ifs. apply Pos.eqb_eq in Heq. rewrite <- Heq. unfold Genv.find_comp, Genv.find_funct. des_ifs. *) - (* unfold Genv.type_of_call. unfold comp_of at 1. simpl. rewrite Pos.eqb_refl; auto. *) - (* } *) - (* { admit. (* fix? VISFO0 --- maybe case analysis first on unknowns? *) } *) - (* } *) - (* (* 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 *. *) - (* replace (Genv.find_comp_ignore_offset ge Vundef) with default_compartment in STUPD0; auto. 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 --- by some hacky reason *) *) - (* clear - PC_RA0. exfalso. simpl in PC_RA0. des_ifs. *) - (* } *) - (* } *) - (* (* stuck case *) *) - (* inv H; simpl in *; rewrite Pregmap.gss in *; inv H11. *) - (* } *) - - (* (** return is ccc --- next is poped from the stack, which is internal, so done *) *) - (* simpl in *. rewrite Pregmap.gss in *. rename H6 into STAR. *) - (* unfold Genv.type_of_call in H. des_ifs. clear H. unfold update_stack_return in STUPD. rewrite Pregmap.gss in *. *) - (* 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 *. destruct WFASM as [WFASM1 WFASM2]. *) - (* inv WFASM1. simpl in *. des_ifs. clear H8. inv MTST2. *) - (* exploit (IH _ _ _ _ _ _ _ _ STAR). lia. all: auto. *) - (* { simpl. split; auto. unfold wf_regset. rewrite Pregmap.gss. rewrite PC_RA. rewrite Heq0. auto. } *) - (* { instantiate (4:=f'). instantiate (3:=m'0). instantiate (2:=[]). instantiate (1:=Some (next, m2', ik_tl)). simpl. split. *) - (* { inv WFIR1. simpl in *. auto. } *) - (* split. *) - (* { inv WFIR1. auto. } *) - (* split; auto. split. *) - (* { unfold match_cur_regset. rewrite Pregmap.gss. rewrite COMP. rewrite PC_RA. auto. } *) - (* split; auto. split; auto. simpl. split; auto. split; auto. *) - (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC. clear - H12 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. *) - (* pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H12). 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. *) - (* } *) - (* split. *) - (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. pose proof (public_not_freeable_exec_instr _ _ _ _ _ _ _ _ MEM3 NALLOC H3) as NFREE. *) - (* pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5') as NALLOC2. *) - (* clear - H12 NFREE NALLOC2. unfold public_not_freeable in *. intros. specialize (NFREE _ H). intros CC. apply NFREE; clear NFREE. *) - (* eapply external_call_max_perm; eauto. unfold Mem.valid_block. unfold meminj_not_alloc in NALLOC2. *) - (* unfold Plt. destruct (Pos.ltb_spec b (Mem.nextblock m')); auto. specialize (NALLOC2 _ H0). congruence. *) - (* } *) - (* split; auto. constructor. *) - (* } *) - (* intros (btr & ist' & UTR & ISTAR'). *) - (* (* FIX: case analysis on whether extcall is unknown or not *) *) - (* exists ([Bundle_call t1 ef_id (vals_to_eventvals ge args) (ef_sig ef) (Some d')] *) - (* ++ ((Bundle_return [Event_return (Genv.find_comp_ignore_offset ge (rs' X1)) (Genv.find_comp_ignore_offset ge (rs' PC)) res0] res0) :: btr)), ist'. *) - (* simpl. rewrite UTR. split; auto. *) - (* econstructor 2. 2: econstructor 2. 3: eapply ISTAR'. 3,4: auto. *) - (* - eapply ir_step_intra_call_external. 2: eapply FINDSYMB. 2: eapply NEXTF. 6: eapply EXTCALL'. all: eauto. *) - (* { unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. *) - (* rewrite H1. setoid_rewrite ALLOWED. simpl. unfold Genv.find_comp. simpl. rewrite pred_dec_true; auto. rewrite NEXTF. *) - (* unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. *) - (* } *) - (* { admit. (* fix? VISFO --- maybe case analysis first on unknowns? *) } *) - (* - inv WFIR1. simpl in *. des_ifs. clear H8. unfold wf_ir_cur in WFIR0. des_ifs. clear WFIR0. *) - (* eapply ir_step_cross_return_internal. 6: eapply Heq1. all: eauto. *) - (* { intros. eapply NO_CROSS_PTR. *) - (* rewrite PC_RA, NEXTPC. simpl. rewrite <- COMP. rewrite MTST1 in H. *) - (* rewrite <- ALLOWED. rewrite H0 in H. simpl in H. unfold Genv.find_comp at 2 in H. unfold Genv.find_funct in H. des_ifs. *) - (* } *) - (* constructor; auto. *) - (* { rewrite COMP, MTST1. rewrite PC_RA, NEXTPC in *. simpl in *. rewrite H0. simpl. unfold Genv.find_comp at 2. unfold Genv.find_funct in *. des_ifs. *) - (* setoid_rewrite ALLOWED. unfold Genv.type_of_call. rewrite Pos.eqb_sym, Heq. auto. *) - (* } *) - (* { replace (funsig (Internal f3)) with sig3; auto. unfold match_cur_stack_sig in MTST0. des_ifs. } *) - (* { rewrite COMP. rewrite PC_RA. simpl. rewrite NEXTPC. simpl. unfold match_cur_regset in MTST1. rewrite MTST1. rewrite H0. simpl. *) - (* replace (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) with (Genv.find_comp ge (Vptr b Ptrofs.zero)); auto. *) - (* rewrite <- ALLOWED. unfold Genv.find_comp. unfold Genv.find_funct. des_ifs. *) - (* } *) - (* } *) - - - - - - - H1 : Genv.find_funct_ptr ge b = Some (Internal f) - ALLOWED : comp_of f = Genv.find_comp_ignore_offset ge (Vptr b0 Ptrofs.zero) - NEXTPC : rs' PC = Vptr b0 Ptrofs.zero - NEXTF : Genv.find_funct_ptr ge b0 = Some (External ef) - - -external_call_mem_inject: - forall (ef : external_function) [F V : Type] [ge : Genv.t F V] [vargs : list val] [m1 : mem] (t : trace) (vres : val) (m2 : mem) [f : block -> option (block * Z)] [m1' : mem] [vargs' : list val], - meminj_preserves_globals ge f -> - external_call ef ge vargs m1 t vres m2 -> - Mem.inject f m1 m1' -> - Val.inject_list f vargs vargs' -> - exists (f' : meminj) (vres' : val) (m2' : mem), - external_call ef ge vargs' m1' t vres' m2' /\ - Val.inject f' vres vres' /\ Mem.inject f' m2 m2' /\ Mem.unchanged_on (loc_unmapped f) m1 m2 /\ Mem.unchanged_on (loc_out_of_reach f m1) m1' m2' /\ inject_incr f f' /\ inject_separated f f' m1 m1' - - - | ir_step_intra_call_external : forall (cur : block) (m1 m2 : mem) (ik : ir_conts) (tr : trace) (id : ident) (evargs : list eventval) (sg : signature) (cp_cur : compartment), - cp_cur = Genv.find_comp ge (Vptr cur Ptrofs.zero) -> - forall (b_ext : block) (ef : external_function) (cp_ext : compartment), - Genv.find_symbol ge id = Some b_ext -> - Genv.find_funct ge (Vptr b_ext Ptrofs.zero) = Some (External ef) -> - cp_ext = comp_of ef -> - Genv.type_of_call ge cp_cur cp_ext = Genv.InternalCall -> - sg = ef_sig ef -> - forall (d : mem_delta) (m1' : mem), - mem_delta_apply d m1 = Some m1' -> - forall (vargs : list val) (vretv : val), - external_call ef ge vargs m1' tr vretv m2 -> - visible_fo_and_unknown ef ge m1 vargs -> evargs = vals_to_eventvals ge vargs -> ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg (Some d)) (Some (cur, m2, ik)) - - - - (* TODO *) - - - - (* OLD *) - unfold wf_asm in WFASM. unfold match_state in MTST. - assert (INTRA: Genv.find_comp ge (Vptr cur Ptrofs.zero) = Genv.find_comp_ignore_offset ge (rs' PC)). - { rewrite MC. rewrite NEXTPC, <- ALLOWED. unfold Genv.find_comp_ignore_offset. rewrite H3. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H4. auto. } - destruct (Genv.find_funct_ptr ge b') eqn:NEXTFUN. destruct f0. - + eapply IH; try reflexivity. 3: eauto. all: auto. - { unfold wf_regset_stack. rewrite NEXTPC, NEXTFUN. auto. } - { admit. (* mem *) } - + (* intra -> external *) - inv STAR. - { constructor 1. } - inv H. all: rewrite NEXTPC in H8; inv H8; rewrite NEXTFUN in H11; inv H11. - inv H0. - { (* trace ends *) - exploit external_call_trace_length. eauto. intros EVLEN. destruct t. - - simpl. constructor 1. - - destruct t; simpl in EVLEN. 2: lia. clear EVLEN. - simpl. pose proof NEXTFUN as NF0. unfold Genv.find_funct_ptr in NF0. destruct (Genv.find_def ge b0) eqn:FDB0; [|inv NF0]. destruct g; inv NF0. - exploit wf_ge_block_to_id; eauto. intros (fid & INV). - econstructor 4; try reflexivity; auto. - { admit. (* ext call sem *) } - { eauto. } - { unfold Genv.allowed_call. right; left. rewrite <- NEXTPC. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. auto. } - { unfold Genv.type_of_call. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. rewrite Pos.eqb_refl. auto. } - { constructor 1. } - } - inv H. - (* replace ((set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (rs' X1) PC) with (rs' X1) in *. *) - (* 2:{ rewrite Pregmap.gss. auto. } *) - destruct (Pos.eqb_spec (callee_comp cpm sk) (Genv.find_comp_ignore_offset ge ((set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (rs' X1) PC))). - { (* intra-return *) - clear PC_RA RESTORE_SP NO_CROSS_PTR. pose proof EV as RETEV. inv RETEV; simpl. - 2:{ exfalso. unfold Genv.type_of_call in H. rewrite <- e in H. rewrite Pos.eqb_refl in H. inv H. } - 2:{ exfalso. unfold Genv.type_of_call in H. rewrite <- e in H. rewrite Pos.eqb_refl in H. inv H. } - assert (STK: st' = sk). - { unfold update_stack_return in STUPD. rewrite <- e in STUPD. rewrite Pos.eqb_refl in STUPD. inv STUPD. auto. } - subst st'. simpl in INFO; subst. simpl. - pose proof H1 as IH_ISTAR. move IH_ISTAR after H1. inv H1. - { (* trace ends *) - exploit external_call_trace_length. eauto. intros EVLEN. destruct t. - { simpl. clear EVLEN. constructor 1. } - destruct t; simpl in EVLEN. 2: lia. clear EVLEN. - pose proof NEXTFUN as NF0. unfold Genv.find_funct_ptr in NF0. destruct (Genv.find_def ge b0) eqn:FDB0; [|inv NF0]. destruct g; inv NF0. - exploit wf_ge_block_to_id. eauto. eapply FDB0. intros (fid & INV). - eapply info_asm_sem_wf_intra_call_external; eauto. - { admit. (* ext call sem *) } - { unfold Genv.allowed_call. right; left. rewrite <- NEXTPC. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. auto. } - { unfold Genv.type_of_call. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. rewrite Pos.eqb_refl. auto. } - { constructor 1. } - } - (* now we case-analysis new PC = (rs' X1) *) - destruct (val_is_ptr_or_not (rs' X1)). - { (* not a Vptr, so booms for every step *) - rename H1 into NP. clear - H0 NP. inv H0; exfalso. all: rewrite Pregmap.gss in H3; eapply NP; eauto. - } - destruct H1 as (b2 & ofs2 & NEXTPC2). destruct (Genv.find_funct_ptr ge b2) eqn:NEXTFUN2. destruct f0. - { (* next fun is internal - done by induction *) - exploit external_call_trace_length. eauto. intros EVLEN. destruct t; simpl. - { clear EVLEN. - eapply IH. 3: eapply IH_ISTAR. all: auto. - - red. rewrite Pregmap.gss. rewrite NEXTPC2. rewrite NEXTFUN2. auto. - - rewrite Pregmap.gss in *. rewrite <- e. rewrite <- REC_CURCOMP. auto. - - admit. (* mem -> need to execute external call to maintain injection? *) - } - destruct t; simpl in *. 2:lia. clear EVLEN. - pose proof NEXTFUN as NF0. unfold Genv.find_funct_ptr in NF0. destruct (Genv.find_def ge b0) eqn:FDB0; [|inv NF0]. destruct g; inv NF0. - exploit wf_ge_block_to_id. eauto. eapply FDB0. intros (fid & INV). - eapply info_asm_sem_wf_intra_call_external; eauto. - { admit. (* ext call sem *) } - { unfold Genv.allowed_call. right; left. rewrite <- NEXTPC. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. auto. } - { unfold Genv.type_of_call. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. rewrite Pos.eqb_refl. auto. } - eapply IH. 3: eapply IH_ISTAR. all: auto. - - red. rewrite Pregmap.gss. rewrite NEXTPC2. rewrite NEXTFUN2. auto. - - rewrite Pregmap.gss in *. rewrite <- e. rewrite <- REC_CURCOMP. auto. - - admit. (* mem *) - } - { (* next fun is external; undef_caller_save_regs sets RA=Vundef, so we take extcall-step, which sets PC=RA, and after the return step, we have PC=Vundef. *) - (* TODO *) - - Abort. - - -End PROOF. - - -Section INFORMATIVE. - Import Smallstep. - - (* At CROSS-COMP calls, if fundef is ext, set to is_cross_ext. Otherwise is_not_ext. *) - (* When a Event_call is is_cross_ext, do not back-translate the following (possible Event_syscall and) Event_return. *) - Variant cross_ext := | is_cross_ext | not_cross_ext. - - Variant real_virtual := | is_real | is_virtual. - - (* Additional information *) - Variant info_kind := - (* Get information for cross-comp calls and returns *) - | info_call (ce: cross_ext) (sg: signature) (vr: real_virtual) - | info_return (sg: signature) (vr: real_virtual) - (* Get information for inter-comp external calls or builtins *) - | info_external (b: block) (sg: signature) - | info_builtin (ef: external_function) - (* | info_default *) - . - - (* Informative events *) - Definition ievent := (event * info_kind)%type. - Definition itrace := list ievent. - - Definition iE0: itrace := nil. - - (* Informative to original *) - Definition iev_to_ev (ie: ievent) : event := (fst ie). - (* Definition itr_to_tr (ies: itrace) : trace := map iev_to_ev ies. *) - - Definition filter_virtual (iev: ievent): bool := - match iev with - | (ev, info_call _ _ is_virtual) | (ev, info_return _ is_virtual) => false - | _ => true - end. - - Definition itr_to_tr (itr: itrace) : trace := map iev_to_ev (filter filter_virtual itr). - - Lemma itr_to_tr_cons - ev tr - : - itr_to_tr (ev :: tr) = if (filter_virtual ev) then (fst ev) :: (itr_to_tr tr) else (itr_to_tr tr). - Proof. unfold itr_to_tr. destruct ev. destruct i; simpl; auto. 1,2: destruct vr; simpl; auto. Qed. - - Lemma itr_to_tr_app - t1 t2 - : - itr_to_tr (t1 ++ t2) = (itr_to_tr t1) ++ (itr_to_tr t2). - Proof. unfold itr_to_tr. rewrite filter_app. rewrite map_app. auto. Qed. - - Lemma filter_map - A B f (m: A -> B) - (l: list A) - (FA: forall a, f (m a) = true) - : - filter f (map m l) = map m l. - Proof. induction l; simpl; auto. rewrite FA. rewrite IHl. auto. Qed. - - (* Informative behavior *) - (* CoInductive itraceinf : Type := iEconsinf : ievent -> itraceinf -> itraceinf. *) - (* CoFixpoint itri_to_tri (itri: itraceinf): traceinf := *) - (* match itri with iEconsinf hd tl => Econsinf (iev_to_ev hd) (itri_to_tri tl) end. *) - - (* Definition itri_to_tri_obs (itri: itraceinf) := *) - (* match itri with iEconsinf hd tl => iEconsinf hd tl end. *) - - (* Lemma itri_to_tri_obs_eq: forall itri, itri_to_tri_obs itri = itri. *) - (* Proof. destruct itri; reflexivity. Qed. *) - - (* Fixpoint iEappinf (t: itrace) (T: itraceinf) {struct t} : itraceinf := *) - (* match t with *) - (* | nil => T *) - (* | ev :: t' => iEconsinf ev (iEappinf t' T) *) - (* end. *) - - - (* Inductive iprogram_behavior : Type := *) - (* iTerminates : itrace -> int -> iprogram_behavior *) - (* | iDiverges : itrace -> iprogram_behavior *) - (* | iReacts : itraceinf -> iprogram_behavior *) - (* | iGoes_wrong : itrace -> iprogram_behavior. *) - - (* Definition iph_to_pb (ipb: iprogram_behavior): program_behavior := *) - (* match ipb with *) - (* | iTerminates itr r => Terminates (itr_to_tr itr) r *) - (* | iDiverges itr => Diverges (itr_to_tr itr) *) - (* | iReacts itri => Reacts (itri_to_tri itri) *) - (* | iGoes_wrong itr => Goes_wrong (itr_to_tr itr) *) - (* end. *) - - Inductive istar {genv state : Type} (step : genv -> state -> itrace -> state -> Prop) (ge : genv) : state -> itrace -> state -> Prop := - istar_refl : forall s : state, istar step ge s nil s - | istar_step : forall (s1 : state) (t1 : itrace) (s2 : state) (t2 : itrace) (s3 : state) (t : itrace), - step ge s1 t1 s2 -> istar step ge s2 t2 s3 -> t = t1 ++ t2 -> istar step ge s1 t s3. - - Inductive istar_measure {genv state : Type} (step : genv -> state -> itrace -> state -> Prop) (ge : genv) : nat -> state -> itrace -> state -> Prop := - istar_measure_refl : forall s : state, istar_measure step ge O s nil s - | istar_measure_step : forall (n: nat) (s1 : state) (t1 : itrace) (s2 : state) (t2 : itrace) (s3 : state) (t : itrace), - step ge s1 t1 s2 -> istar_measure step ge n s2 t2 s3 -> t = t1 ++ t2 -> istar_measure step ge (S n) s1 t s3. - - Lemma measure_istar - genv state - (step : genv -> state -> itrace -> state -> Prop) - (ge : genv) - s0 tr s1 - (STAR: istar step ge s0 tr s1) - : - exists n, istar_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. - - (* Record isemantics : Type := *) - (* iSemantics_gen *) - (* { istate : Type; *) - (* igenvtype : Type; *) - (* istep : igenvtype -> istate -> itrace -> istate -> Prop; *) - (* iinitial_state : istate -> Prop; *) - (* ifinal_state : istate -> int -> Prop; *) - (* iglobalenv : igenvtype; *) - (* isymbolenv : Senv.t *) - (* }. *) - - (* Definition sem_to_isem (L: Smallstep.semantics) (istep: (genvtype L) -> (state L) -> itrace -> (state L) -> Prop) : isemantics := *) - (* iSemantics_gen _ _ istep (initial_state L) (final_state L) (globalenv L) (symbolenv L). *) - - (* CoInductive iforever_silent (genv state : Type) (step : genv -> state -> itrace -> state -> Prop) (ge : genv) : state -> Prop := *) - (* iforever_silent_intro : forall s1 s2 : state, step ge s1 nil s2 -> iforever_silent _ _ step ge s2 -> iforever_silent _ _ step ge s1. *) - - (* CoInductive iforever_reactive (genv state : Type) (step : genv -> state -> itrace -> state -> Prop) (ge : genv) : state -> itraceinf -> Prop := *) - (* iforever_reactive_intro : forall (s1 s2 : state) (t : itrace) (T : itraceinf), *) - (* istar step ge s1 t s2 -> t <> nil -> iforever_reactive _ _ step ge s2 T -> iforever_reactive _ _ step ge s1 (iEappinf t T). *) - - (* Definition inostep := fun (genv state : Type) (step : genv -> state -> itrace -> state -> Prop) (ge : genv) (s : state) => forall (t : itrace) (s' : state), ~ step ge s t s'. *) - - (* Inductive istate_behaves (L : semantics) (istep: (genvtype L) -> (state L) -> itrace -> (state L) -> Prop) (s : state L): itrace -> program_behavior -> Prop := *) - (* istate_terminates : forall (t : itrace) (s' : state L) (r : int), *) - (* (istar istep (globalenv L)) s t s' -> final_state L s' r -> istate_behaves L istep s t (Terminates (itr_to_tr t) r) *) - (* | istate_diverges : forall (t : itrace) (s' : state L), *) - (* (istar (istep) (globalenv L)) s t s' -> (forever_silent _ _ (step L) (globalenv L)) s' -> istate_behaves L istep s t (Diverges (itr_to_tr t)) *) - (* | istate_reacts : forall (t: itrace) (T : traceinf), *) - (* (iforever_reactive _ _ (istep L) (iglobalenv L)) s T -> istate_behaves L istep s t (Reacts T) *) - (* | istate_goes_wrong : forall (t : itrace) (s' : istate L), *) - (* (istar (istep L) (iglobalenv L)) s t s' -> (inostep _ _ (istep L) (iglobalenv L)) s' -> (forall r : int, ~ ifinal_state L s' r) -> istate_behaves L s (iGoes_wrong t). *) - - (* Inductive iprogram_behaves (L : semantics) (istep: (genvtype L) -> (state L) -> itrace -> (state L) -> Prop): itrace -> program_behavior -> Prop := *) - (* iprogram_runs : forall (s : state L) (t: itrace) (beh : iprogram_behavior), *) - (* initial_state L s -> istate_behaves L istep s t beh -> iprogram_behaves L t beh *) - (* | iprogram_goes_initially_wrong : (forall s : state L, ~ initial_state L s) -> iprogram_behaves L nil (Goes_wrong nil). *) - - Definition istep (L: Smallstep.semantics) := (genvtype L) -> (state L) -> itrace -> (state L) -> Prop. - - Definition state_has_trace_informative (L: Smallstep.semantics) (s: state L) (step: istep L) (t: itrace): Prop := - (exists s', (istar step (globalenv L)) s t s'). - - Variant semantics_has_initial_trace_informative (L: Smallstep.semantics) (step: istep L) (t: itrace) : Prop := - | semantics_info_runs : - forall s, (initial_state L s) -> (state_has_trace_informative L s step t) -> semantics_has_initial_trace_informative _ _ t - | semantics_info_goes_initially_wrong : (forall s : state L, ~ initial_state L s) -> (t = nil) -> semantics_has_initial_trace_informative _ _ t. - -End INFORMATIVE. - - -Lemma iE0_left: forall t, iE0 ++ t = t. -Proof. auto. Qed. - -Lemma iE0_right: forall t, t ++ iE0 = t. -Proof. intros. unfold iE0, Eapp. rewrite <- app_nil_end. auto. Qed. - -Lemma iEapp_assoc: forall (t1 t2 t3: itrace), (t1 ++ t2) ++ t3 = t1 ++ (t2 ++ t3). -Proof. intros. unfold Eapp, trace. apply app_ass. Qed. - -Lemma iEapp_E0_inv: forall t1 t2, t1 ++ t2 = iE0 -> t1 = iE0 /\ t2 = iE0. -Proof. eapply (@app_eq_nil ievent). Qed. - -(* Lemma iE0_left_inf: forall T, iEappinf iE0 T = T. *) -(* Proof. auto. Qed. *) - -(* Lemma iEappinf_assoc: forall t1 t2 T, iEappinf (t1 ++ t2) T = iEappinf t1 (iEappinf t2 T). *) -(* Proof. *) -(* induction t1; intros; simpl. auto. decEq; auto. *) -(* Qed. *) - -#[global] -Hint Rewrite iE0_left iE0_right iEapp_assoc: itrace_rewrite. -(* Hint Rewrite iE0_left iE0_right iEapp_assoc *) -(* iE0_left_inf iEappinf_assoc: itrace_rewrite. *) - -Ltac isubstTraceHyp := - match goal with - | [ H: (@eq itrace ?x ?y) |- _ ] => - subst x || clear H - end. - -Ltac idecomposeTraceEq := - match goal with - | [ |- (_ ++ _) = (_ ++ _) ] => - apply (f_equal2 app); auto; decomposeTraceEq - | _ => - auto - end. - -Ltac itraceEq := - repeat isubstTraceHyp; autorewrite with itrace_rewrite; idecomposeTraceEq. - - -(* Section AUX. *) - -(* Definition ibehavior_app (t: itrace) (beh: iprogram_behavior): iprogram_behavior := *) -(* match beh with *) -(* | iTerminates t1 r => iTerminates (t ++ t1) r *) -(* | iDiverges t1 => iDiverges (t ++ t1) *) -(* | iReacts T => iReacts (iEappinf t T) *) -(* | iGoes_wrong t1 => iGoes_wrong (t ++ t1) *) -(* end. *) - -(* Lemma ibehavior_app_assoc: *) -(* forall t1 t2 beh, *) -(* ibehavior_app (t1 ++ t2) beh = ibehavior_app t1 (ibehavior_app t2 beh). *) -(* Proof. *) -(* intros. destruct beh; simpl; f_equal; itraceEq. *) -(* Qed. *) - -(* Lemma ibehavior_app_E0: *) -(* forall beh, ibehavior_app iE0 beh = beh. *) -(* Proof. *) -(* destruct beh; auto. *) -(* Qed. *) - -(* Definition ibehavior_prefix (t: itrace) (beh: iprogram_behavior) : Prop := *) -(* exists beh', beh = ibehavior_app t beh'. *) - -(* End AUX. *) - - -Section AUX. - - Definition block_first_order (m: mem) (b: block): Prop := - forall (ofs: Z), - match (ZMap.get ofs (Mem.mem_contents m) !! b) with - | Fragment vv _ _ => not_ptr vv - | _ => True - end. - - (* Definition val_first_order (m: mem) (v: val): Prop := *) - (* match v with *) - (* | Vptr b _ => block_first_order m b *) - (* | _ => True *) - (* end. *) - - (* Redundant - we enforce Event_syscall to respect eventval_list_match on args, - which enforce pointers to be public - which are first-order by the semantics *) - (* Definition syscall_args_first_order (m: mem) (args: list val) := *) - (* Forall (val_first_order m) args. *) - - (* Public symbols are visible outside the compilation unit, - so when interacting via external calls, limit them to first-order. *) - Definition public_first_order (ge: Senv.t) (m: mem) := - forall id b (PUBLIC: Senv.public_symbol ge id = true) (FIND: Senv.find_symbol ge id = Some b), - block_first_order m b. - -End AUX. - -Section ASMISTEP. - - Variable cpm: compartment. - Variable ge: genv. - - (* Parameter low_half: genv -> ident -> ptrofs -> ptrofs. *) - (* Parameter high_half: genv -> ident -> ptrofs -> val. *) - - (* Axiom low_high_half: *) - (* forall id ofs, *) - (* Val.offset_ptr (high_half ge id ofs) (low_half ge id ofs) = Genv.symbol_address ge id ofs. *) - - 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 => EVfloat Floats.Float.zero - end. - - Definition typ_to_eventvals (ty: list typ): list eventval := map typ_to_eventval ty. - - Definition genv_invert_symbol_total {F V : Type} (ge : Genv.t F V) : block -> ident := - fun b => match Genv.invert_symbol ge b with | Some i => i | None => xH end. - - Inductive call_trace_cross {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> val -> list val -> list typ -> trace -> Prop := - call_trace_cross_intra : forall (cp cp' : compartment) (vf : val) (vargs : list val) (ty : list typ), - Genv.type_of_call ge cp cp' = Genv.InternalCall -> call_trace_cross ge cp cp' vf vargs ty E0 - | call_trace_cross_virtual : forall (cp cp' : compartment) (vf : val) (vargs : list val) (vl : list eventval) (ty : list typ) (b : block) (ofs : ptrofs) (i : ident), - Genv.type_of_call ge cp cp' = Genv.DefaultCompartmentCall -> - vf = Vptr b ofs -> genv_invert_symbol_total ge b = i -> (vl = typ_to_eventvals ty) -> call_trace_cross ge cp cp' vf vargs ty (Event_call cp cp' i vl :: nil) - | call_trace_cross_cross : forall (cp cp' : compartment) (vf : val) (vargs : list val) (vl : list eventval) (ty : list typ) (b : block) (ofs : ptrofs) (i : ident), - Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> - vf = Vptr b ofs -> Genv.invert_symbol ge b = Some i -> eventval_list_match ge vl ty vargs -> call_trace_cross ge cp cp' vf vargs ty (Event_call cp cp' i vl :: nil). - - Inductive return_trace_cross {F V : Type} (ge : Genv.t F V) : compartment -> compartment -> val -> rettype -> trace -> Prop := - return_trace_cross_intra : forall (cp cp' : compartment) (v : val) (ty : rettype), - Genv.type_of_call ge cp cp' = Genv.InternalCall -> return_trace_cross ge cp cp' v ty E0 - | return_trace_cross_virtual : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype), - Genv.type_of_call ge cp cp' = Genv.DefaultCompartmentCall -> (res = typ_to_eventval (proj_rettype ty)) -> return_trace_cross ge cp cp' v ty (Event_return cp cp' res :: nil) - | return_trace_cross_cross : forall (cp cp' : compartment) (res : eventval) (v : val) (ty : rettype), - Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall -> eventval_match ge res (proj_rettype ty) v -> return_trace_cross ge cp cp' v ty (Event_return cp cp' res :: nil). - - Variant asm_istep: state -> itrace -> state -> Prop := - | exec_asm_istep_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 ge 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')), - asm_istep (State st rs m) nil (State st rs' m') - | exec_asm_istep_internal_call: - forall b ofs f i sig rs m rs' m' b' ofs' cp st st' args t it, - 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 ge 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' ofs')), - 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 ge 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_cross ge (comp_of f) (Genv.find_comp_ignore_offset ge (Vptr b' ofs')) (Vptr b' ofs') - args (sig_args sig) t), - forall (INFO: let ce := match (Genv.find_funct_ptr ge b', (comp_of f) =? (Genv.find_comp_ignore_offset ge (Vptr b' ofs'))) with - | (Some (External ef), false) => is_cross_ext - | _ => not_cross_ext - end in - let vr := match Genv.type_of_call ge (comp_of f) (Genv.find_comp_ignore_offset ge (Vptr b' ofs')) with - | Genv.DefaultCompartmentCall => is_virtual - | _ => is_real - end in - it = map (fun e => (e, info_call ce sig vr)) t), - forall (CALLSIG: Genv.type_of_call ge (comp_of f) (Genv.find_comp_ignore_offset ge (Vptr b' ofs')) <> Genv.InternalCall -> - (exists fd, Genv.find_funct_ptr ge b' = Some fd /\ sig = Asm.funsig fd)), - forall (CPEQ: cp = (comp_of f)), - asm_istep (State st rs m) it (State st' rs' m') - | exec_asm_istep_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 ge 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 cpm st), - (* forall (NEXTCOMP: Genv.find_comp_ignore_offset ge (rs' PC) = cp'), *) - asm_istep (State st rs m) nil (ReturnState st rs' m') - | exec_asm_istep_return: - forall st st' rs m sg t rec_cp rec_cp' cp' it, - rs PC <> Vnullptr -> (* this condition is there to stop the execution 1 asm_istep earlier, to make the proof easier *) - forall (REC_CURCOMP: callee_comp cpm st = rec_cp), - forall (REC_NEXTCOMP: call_comp ge 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 ge 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_cross ge cp' rec_cp (return_value rs sg) (sig_res sg) t), - forall (INFO: let vr := match Genv.type_of_call ge cp' rec_cp with - | Genv.DefaultCompartmentCall => is_virtual - | _ => is_real - end in - it = map (fun e => (e, info_return sg vr)) t), - asm_istep (ReturnState st rs m) it (State st' rs m) - | exec_asm_istep_builtin: - forall b ofs f ef args res rs m vargs t vres rs' m' st it, - 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 res) -> - eval_builtin_args ge rs (rs SP) m args vargs -> - external_call ef ge (comp_of f) vargs m t vres m' -> - rs' = nextinstr - (set_res res vres - (undef_regs (map preg_of (destroyed_by_builtin ef)) - (rs #X1 <- Vundef #X31 <- Vundef))) -> - forall (INFO: it = map (fun e => (e, info_builtin ef)) t), - asm_istep (State st rs m) it (State st rs' m') - | exec_asm_istep_external: - forall b ef args res rs m t rs' m' cp st it, - 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 cp 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_asm_istep_internal_return] case. *) - forall (REC_CURCOMP: Genv.find_comp_ignore_offset ge (rs PC) = callee_comp cpm st), - forall (INFO: it = map (fun e => (e, info_external b (ef_sig ef))) t), - forall (PFO: public_first_order ge m), - asm_istep (State st rs m) it (ReturnState st rs' m'). - - (* TODO: fix all the semantics, add CALLSIG and PFO *) - -End ASMISTEP. - - -Section ASMITR. - - Definition asm_has_initial_trace_informative (p: Asm.program) (t: itrace) := - semantics_has_initial_trace_informative (semantics p) (asm_istep (comp_of_main p)) t. - - Definition asm_has_initial_trace (p: Asm.program) (t: trace): Prop := semantics_has_initial_trace_prefix (Asm.semantics p) t. - - - (* TODO: fix Asm sem *) - Lemma asm_star_tr_implies_istar_info_tr - (p: Asm.program) (t: trace) - (s s': Asm.state) - (STAR: Star (semantics p) s t s') - : - exists it, (state_has_trace_informative (semantics p) s (asm_istep (comp_of_main p)) it) /\ (itr_to_tr it = t). - Proof. - simpl in STAR. induction STAR. - { exists nil. simpl; split; auto. exists s. econstructor 1. } - destruct IHSTAR as (it & (s2' & ISTAR) & ITR). subst. - move H after ISTAR. inv H. - - exists (it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 1; eauto. simpl. rewrite ALLOWED in H3. unfold Genv.find_comp_ignore_offset in H3. auto. } - auto. - - pose proof EV as EV0. - destruct (Genv.type_of_call (Genv.globalenv p) (comp_of f) (Genv.find_comp_ignore_offset (Genv.globalenv p) (Vptr b' ofs'))) eqn:CCASES. - + inv EV0. 2: rewrite CCASES in H; inv H. - exists (it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 2; eauto. - - simpl. setoid_rewrite CCASES. intros F; inv F. - - econstructor 1. auto. - - simpl. setoid_rewrite CCASES. intros F; contradiction F. auto. - - simpl. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H1. auto. - } - auto. - + inv EV0. rewrite CCASES in H. congruence with H. - assert (CASES: (exists ef, Genv.find_funct_ptr (Genv.globalenv p) b' = Some (External ef)) \/ - ((exists intf, Genv.find_funct_ptr (Genv.globalenv p) b' = Some (Internal intf)) \/ (Genv.find_funct_ptr (Genv.globalenv p) b' = None))). - { destruct (Genv.find_funct_ptr (Genv.globalenv p) b') eqn:CASES; [|auto]. destruct f0; eauto. } - destruct CASES as [EXT | ELSE]. - * exists ((Event_call (comp_of f) (Genv.find_comp_ignore_offset (Genv.globalenv p) (Vptr b' ofs')) i0 vl, info_call is_cross_ext sig is_real) :: it). simpl. split; [|auto]. - exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 2; eauto. - - simpl. econstructor 3; eauto. - - admit. (* signature *) - - simpl. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H1. auto. - } - simpl. destruct EXT. rewrite H8. unfold Genv.find_comp_ignore_offset in H. rewrite H. - clear - H. unfold Genv.type_of_call in H. destruct (comp_of f =? Genv.find_comp (Genv.globalenv p) (Vptr b' Ptrofs.zero)). inv H. auto. - * exists ((Event_call (comp_of f) (Genv.find_comp_ignore_offset (Genv.globalenv p) (Vptr b' ofs')) i0 vl, info_call not_cross_ext sig is_real) :: it). simpl. split; [|auto]. - exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 2; eauto. - - simpl. econstructor 3; eauto. - - admit. (* signature *) - - simpl. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H1. auto. - } - simpl. unfold Genv.find_comp_ignore_offset in H. rewrite H. destruct ELSE. destruct H8. rewrite H8. auto. rewrite H8. auto. - + inv EV0. - 2:{ rewrite CCASES in H. inv H. } - assert (CASES: (exists ef, Genv.find_funct_ptr (Genv.globalenv p) b' = Some (External ef)) \/ - ((exists intf, Genv.find_funct_ptr (Genv.globalenv p) b' = Some (Internal intf)) \/ (Genv.find_funct_ptr (Genv.globalenv p) b' = None))). - { destruct (Genv.find_funct_ptr (Genv.globalenv p) b') eqn:CASES; [|auto]. destruct f0; eauto. } - destruct (Genv.invert_symbol (Genv.globalenv p) b') eqn:SYMB. - 2:{ destruct CASES as [EXT | ELSE]. - * exists ((Event_call (comp_of f) (Genv.find_comp_ignore_offset (Genv.globalenv p) (Vptr b' ofs')) xH (typ_to_eventvals (sig_args sig)), info_call is_cross_ext sig is_virtual) :: it). simpl. split; [|auto]. - exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 2; eauto. - - setoid_rewrite CCASES. intros F; inv F. - - simpl. econstructor 2; eauto. - - admit. (* signature *) - - simpl. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H1. auto. - } - simpl. destruct EXT. rewrite H5. unfold Genv.find_comp_ignore_offset in CCASES. rewrite CCASES. - unfold genv_invert_symbol_total. rewrite SYMB. - clear - CCASES. unfold Genv.type_of_call in CCASES. destruct (comp_of f =? Genv.find_comp (Genv.globalenv p) (Vptr b' Ptrofs.zero)); auto. inv CCASES. - * exists ((Event_call (comp_of f) (Genv.find_comp_ignore_offset (Genv.globalenv p) (Vptr b' ofs')) xH (typ_to_eventvals (sig_args sig)), info_call not_cross_ext sig is_virtual) :: it). simpl. split; [|auto]. - exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 2; eauto. - - setoid_rewrite CCASES. intros F; inv F. - - simpl. econstructor 2; eauto. - - admit. (* signature *) - - simpl. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H1. auto. - } - simpl. unfold Genv.find_comp_ignore_offset in CCASES. rewrite CCASES. unfold genv_invert_symbol_total. rewrite SYMB. destruct ELSE. - destruct H5; rewrite H5. auto. rewrite H5. auto. - } - destruct CASES as [EXT | ELSE]. - * exists ((Event_call (comp_of f) (Genv.find_comp_ignore_offset (Genv.globalenv p) (Vptr b' ofs')) i0 (typ_to_eventvals (sig_args sig)), info_call is_cross_ext sig is_virtual) :: it). simpl. split; [|auto]. - exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 2; eauto. - - setoid_rewrite CCASES. intros F; inv F. - - simpl. econstructor 2; eauto. - - admit. (* signature *) - - simpl. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H1. auto. - } - simpl. destruct EXT. rewrite H5. unfold Genv.find_comp_ignore_offset in CCASES. rewrite CCASES. - unfold genv_invert_symbol_total. rewrite SYMB. - clear - CCASES. unfold Genv.type_of_call in CCASES. destruct (comp_of f =? Genv.find_comp (Genv.globalenv p) (Vptr b' Ptrofs.zero)); auto. inv CCASES. - * exists ((Event_call (comp_of f) (Genv.find_comp_ignore_offset (Genv.globalenv p) (Vptr b' ofs')) i0 (typ_to_eventvals (sig_args sig)), info_call not_cross_ext sig is_virtual) :: it). simpl. split; [|auto]. - exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 2; eauto. - - setoid_rewrite CCASES. intros F; inv F. - - simpl. econstructor 2; eauto. - - admit. (* signature *) - - simpl. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H1. auto. - } - simpl. unfold Genv.find_comp_ignore_offset in CCASES. rewrite CCASES. unfold genv_invert_symbol_total. rewrite SYMB. destruct ELSE. - destruct H5; rewrite H5. auto. rewrite H5. auto. - - exists (it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 3; eauto. } - auto. - - pose proof EV as EV0. - destruct (Genv.type_of_call (Genv.globalenv p) (Genv.find_comp_ignore_offset (Genv.globalenv p) (rs PC)) (callee_comp (comp_of_main p) st)) eqn:CCASES. - + inv EV0. - 2:{ rewrite CCASES in H. inv H. } - exists (it). simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 4; eauto. - - simpl. rewrite CCASES. intros F; inv F. - - econstructor 1; auto. - } - auto. - + inv EV0. rewrite CCASES in H. congruence with H. - exists ((Event_return (Genv.find_comp_ignore_offset (Genv.globalenv p) (rs PC)) (callee_comp (comp_of_main p) st) res, info_return (sig_of_call st) is_real) :: it). - simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 4; eauto. econstructor 3; eauto. } - simpl. rewrite CCASES. auto. - + inv EV0. - 2:{ rewrite CCASES in H. inv H. } - exists ((Event_return (Genv.find_comp_ignore_offset (Genv.globalenv p) (rs PC)) (callee_comp (comp_of_main p) st) (typ_to_eventval (proj_rettype (sig_res (sig_of_call st)))), info_return (sig_of_call st) is_virtual) :: it). - simpl. split; [|auto]. exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 4; eauto. - - simpl. rewrite CCASES. intros F; inv F. - - econstructor 2; eauto. - } - simpl. rewrite CCASES. auto. - - exists ((map (fun e => (e, info_builtin ef)) t1) ++ it). simpl; split. - 2:{ rewrite itr_to_tr_app. unfold Eapp. f_equal. unfold itr_to_tr. rewrite filter_map; simpl; auto. rewrite map_map. simpl. apply map_id. } - exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 5; eauto. } - auto. - - exists ((map (fun e => (e, info_external b (ef_sig ef))) t1) ++ it). simpl; split. - 2:{ rewrite itr_to_tr_app. unfold Eapp. f_equal. unfold itr_to_tr. rewrite filter_map; simpl; auto. rewrite map_map. simpl. apply map_id. } - exists s2'. econstructor 2. 2: eapply ISTAR. - { econstructor 6; eauto. - admit. (* public first order *) - } - auto. - Admitted. - - Lemma asm_tr_implies_info_tr - (p: Asm.program) (t: trace) - (HAS: asm_has_initial_trace p t) - : - exists (it: itrace), (asm_has_initial_trace_informative p it) /\ (itr_to_tr it = t). - Proof. - apply semantics_has_initial_trace_prefix_implies_cut in HAS. 2: apply sd_traces; apply Asm.semantics_determinate. - unfold asm_has_initial_trace_informative. inv HAS. - 2:{ exists nil. simpl; split; auto. econstructor 2; auto. } - destruct H0 as (s' & beh & STAR & BEH). exploit asm_star_tr_implies_istar_info_tr; eauto. intros (it & STTRIF & ITRTR). - exists it. split; [|auto]. econstructor 1; eauto. - Qed. - -End ASMITR. +End PROOF. From 2a1c3714282fc63284b0942caad2f9aadd6213b0 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 3 Aug 2023 18:06:07 +0200 Subject: [PATCH 100/174] WIP --- security/BtInfoAsm.v | 288 +++++++++++++++++++++++-------------------- 1 file changed, 153 insertions(+), 135 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 56f36c8a90..a2a0b165da 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -485,7 +485,6 @@ Section FROMASM. Lemma mem_delta_exec_instr (ge: genv) f i rs m cp rs' m' - (* comp_of f ? *) (NFREE: public_not_freeable ge m) (EXEC: exec_instr ge f i rs m cp = Next rs' m') m0 d @@ -766,6 +765,157 @@ Section PROOF. { 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 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') *) +(* : *) +(* visible_fo ge m' tys args. *) +(* Proof. *) +(* destruct VFO as [PFO VP]. split; auto. clear VP. clear - PFO MEMINJ. *) +(* unfold public_first_order in *. intros. exploit PFO; clear PFO; eauto. *) +(* { instantiate (1:=ofs). *) +(* Mem.perm_inject_inv: *) +(* forall (f : meminj) (m1 m2 : mem) (b1 : block) (ofs : Z) (b2 : block) (delta : Z) (k : perm_kind) (p : permission), *) +(* Mem.inject f m1 m2 -> f b1 = Some (b2, delta) -> Mem.perm m2 b2 (ofs + delta) k p -> Mem.perm m1 b1 ofs k p \/ ~ Mem.perm m1 b1 ofs Max Nonempty *) + +(* 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') *) +(* : *) +(* external_call_unknowns ef ge m' args. *) +(* Proof. *) +(* unfold external_call_unknowns in *. des_ifs. *) + + Lemma match_mem_external_call_establish1 + (ge: genv) k d m_a0 m_i m + (MEM: match_mem ge 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_inj (meminj_public ge) 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 k2 [] m' m2 m' /\ Val.inject k2 res res') + . + Proof. + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5). + (* 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 f' [] m' m_i'' m'). + { unfold match_mem. simpl. splits; auto. + { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. + 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. + } + { 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. + } + constructor. + } + exists m_i', m_i'', vres'. splits; eauto. + { clear - ECC MEMINJ'. admit. + +Mem.perm_drop_1: + forall (m : mem) (b : block) (lo hi : Z) (p : permission) (cp : compartment) (m' : mem), + Mem.drop_perm m b lo hi p cp = Some m' -> forall (ofs : Z) (k : perm_kind), (lo <= ofs < hi)%Z -> Mem.perm m' b ofs k p + +Genv.alloc_global = +fun (F V : Type) (CF : has_comp F) (ge : Genv.t F V) (m : mem) (idg : ident * globdef F V) => +let (_, g) := idg in +match g with +| Gfun f => let (m1, b) := Mem.alloc m (comp_of f) 0 1 in Mem.drop_perm m1 b 0 1 Nonempty (comp_of f) +| Gvar v => + let init := gvar_init v in + let comp := gvar_comp v in + let sz := init_data_list_size init in + let (m1, b) := Mem.alloc m comp 0 sz in + match store_zeros m1 b 0 sz comp with + | Some m2 => match Genv.store_init_data_list ge m2 b 0 init comp with + | Some m3 => Mem.drop_perm m3 b 0 sz (Genv.perm_globvar v) comp + | None => None + end + | None => None + end +end + : forall F V : Type, has_comp F -> Genv.t F V -> mem -> ident * globdef F V -> option mem + + + (* visible_fo *) } + Admitted. + + Lemma asm_to_ir_returnstate_nccc_internal cpm (ge: genv) n n0 (LT: (n0 < n)%nat) @@ -830,51 +980,6 @@ Section PROOF. exists btr, ist'. split; auto. Qed. - Lemma match_mem_external_call_establish1 - (ge: genv) k d m_a0 m_i m - (MEM: match_mem ge 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_inj (meminj_public ge) 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 k2 [] m' m2 m' /\ Val.inject k2 res res') - . - Proof. - destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5). - (* reestablish meminj *) - exploit mem_delta_apply_establish_inject; eauto. - { apply meminj_public_strict. } - { admit. (* ECU *) } - intros (m_i' & APPD' & MEMINJ'). hexploit external_call_mem_inject. 2: eapply EXTCALL. all: eauto. - { admit. (* ez *) } - { instantiate (1:=args). admit. } - intros (f' & vres' & m_i'' & EXTCALL' & VALINJ' & MEMINJ'' & _ & _ & INCRINJ' & _). - assert (MM': match_mem ge f' [] m' m_i'' m'). - { unfold match_mem. simpl. splits; auto. - { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. - 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. - } - { 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. - } - constructor. - } - exists m_i', m_i'', vres'. splits; eauto. - { clear - ECC MEMINJ'. admit. (* visible_fo *) } - Admitted. - Lemma match_mem_external_call_establish2 ge k d m_a0 m_i m (MEM: match_mem ge k d m_a0 m_i m) @@ -907,26 +1012,6 @@ Section PROOF. } { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } Qed. - (* destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5). *) - (* unfold external_call_known_observables in ECKO. *) - (* des_ifs; simpl in *. *) - (* { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. exists []. esplits; eauto. 4: unfold match_mem; splits; eauto. *) - (* simpl. eauto. 1,2: econs; econs; eauto. *) - (* } *) - (* { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. exists []. esplits; eauto. 4: unfold match_mem; splits; eauto. *) - (* simpl. eauto. 1,2: econs; econs; eauto. *) - (* } *) - (* { 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. exists []. esplits; eauto. 4: unfold match_mem; splits; eauto. *) - (* simpl. eauto. 1,2: econs; eauto. *) - (* } *) - (* { destruct ECKO as [_ OBS]. inv EXTCALL. exists []. esplits; eauto. 4: unfold match_mem; splits; eauto. *) - (* simpl. eauto. 1,2: econs; eauto. *) - (* } *) - (* { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } *) - (* Qed. *) Lemma match_mem_external_call_establish (ge: genv) k d m_a0 m_i m @@ -998,42 +1083,6 @@ Section PROOF. { 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. } - (* reestablish meminj *) - (* exploit mem_delta_apply_establish_inject; eauto. *) - (* { admit. (* ez *) } *) - (* { admit. (* ECU *) } *) - (* intros (m_i' & APPD' & MEMINJ'). exploit external_call_mem_inject; eauto. *) - (* { admit. (* ez *) } *) - (* { instantiate (1:=args). admit. } *) - (* intros (f' & vres' & m_i'' & EXTCALL' & VALINJ' & MEMINJ'' & _ & _ & INCRINJ' & _). *) - (* assert (MM': match_mem ge f' [] m' m_i'' m'). *) - (* { unfold match_mem. simpl. split; auto. split; auto. split. *) - (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. *) - (* clear - H4 NALLOC. unfold meminj_not_alloc in *. intros. apply NALLOC. *) - (* pose proof (@external_call_valid_block _ _ _ _ _ _ _ b H4). *) - (* destruct (Pos.leb_spec (Mem.nextblock m_a) b); auto. *) - (* unfold Mem.valid_block in H0. apply H0 in H1. exfalso. unfold Plt in H1. lia. *) - (* } *) - (* split. *) - (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. *) - (* clear - H4 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_a)); auto. *) - (* specialize (NALLOC _ H0). congruence. *) - (* } *) - (* split; auto. constructor. *) - (* } *) - (* exists ([Bundle_call t ef_id (vals_to_eventvals ge args) (ef_sig ef0) (Some d)]). *) - (* do 5 eexists. splits; simpl. 3: eapply MM'. 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. *) - (* } *) - (* { clear - ECU MEMINJ'. left. admit. (* TODO *) } *) - (* extcall is known and observable *) rename H4 into EXTCALL, H7 into EXTARGS. unfold external_call_known_observables in ECKO. @@ -1150,7 +1199,7 @@ Section PROOF. exists [], k, d, m_a0, m_i, m'. simpl. splits; auto. 2: split; auto. 2: eauto. econstructor 1. } - Admitted. + Qed. Lemma asm_to_ir_builtin (ge: genv) @@ -1184,37 +1233,6 @@ Section PROOF. do 4 eexists. splits; simpl. 3: eapply x3. apply app_nil_r. econstructor 2. 2: econstructor 1. 2: eauto. eapply ir_step_builtin; eauto. - (* reestablish meminj *) - (* exploit mem_delta_apply_establish_inject; eauto. *) - (* { admit. (* ez *) } *) - (* { admit. (* ECU *) } *) - (* intros (m_i' & APPD' & MEMINJ'). exploit external_call_mem_inject; eauto. *) - (* { admit. (* ez *) } *) - (* { instantiate (1:=vargs). admit. } *) - (* intros (f' & vres' & m_i'' & EXTCALL' & VALINJ' & MEMINJ'' & _ & _ & INCRINJ' & _). *) - (* assert (MM': match_mem ge f' [] m' m_i'' m'). *) - (* { unfold match_mem. simpl. splits; auto. *) - (* { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. *) - (* 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. *) - (* } *) - (* { 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. *) - (* } *) - (* constructor. *) - (* } *) - (* exists ([Bundle_builtin t1 ef (vals_to_eventvals ge vargs) d]). *) - (* do 4 eexists. splits; simpl. 3: eapply MM'. apply app_nil_r. *) - (* econstructor 2. 2: econstructor 1. 2: eauto. *) - (* eapply ir_step_builtin; eauto. *) - (* { clear - ECU MEMINJ'. left. admit. (* TODO *) } *) - (* extcall is known and observable *) unfold external_call_known_observables in ECKO. @@ -1326,7 +1344,7 @@ Section PROOF. exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: split; auto. econstructor 1. } - Admitted. + Qed. Lemma asm_to_ir_returnstate_undef_nccc_external From aaffcadafe8bc1f841c440d48cb61afeb261e651 Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 4 Aug 2023 16:02:40 +0200 Subject: [PATCH 101/174] proved asm to ir --- common/Events.v | 31 ++++ security/BtInfoAsm.v | 347 +++++++++++++++++++++++++++++++------------ 2 files changed, 279 insertions(+), 99 deletions(-) diff --git a/common/Events.v b/common/Events.v index dee05bf981..74e55d856d 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 *) @@ -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). diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index a2a0b165da..5440529987 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -388,6 +388,19 @@ Section MEASURE. 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 => False + end. + +End CONDS. + + Section FROMASM. Import ListNotations. @@ -466,8 +479,6 @@ Section FROMASM. end); simpl. - Definition public_not_freeable ge m := forall b, (meminj_public ge b <> None) -> (forall ofs, ~ Mem.perm m b ofs Max Freeable). - Lemma public_not_freeable_free_inj_none ge m (NFREE: public_not_freeable ge m) @@ -599,6 +610,84 @@ Section FROMASM. { 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) @@ -711,7 +800,8 @@ Section INVS. 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 j d) /\ (mem_delta_apply d (Some m_a0) = Some m_a1). + (mem_delta_inj_wf 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 @@ -731,7 +821,6 @@ Section PROOF. 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') @@ -816,30 +905,72 @@ Section PROOF. unfold external_call_unknowns in ECC. des_ifs; eapply visible_fo_val_inject_list; eauto. 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') *) -(* : *) -(* visible_fo ge m' tys args. *) -(* Proof. *) -(* destruct VFO as [PFO VP]. split; auto. clear VP. clear - PFO MEMINJ. *) -(* unfold public_first_order in *. intros. exploit PFO; clear PFO; eauto. *) -(* { instantiate (1:=ofs). *) -(* Mem.perm_inject_inv: *) -(* forall (f : meminj) (m1 m2 : mem) (b1 : block) (ofs : Z) (b2 : block) (delta : Z) (k : perm_kind) (p : permission), *) -(* Mem.inject f m1 m2 -> f b1 = Some (b2, delta) -> Mem.perm m2 b2 (ofs + delta) k p -> Mem.perm m1 b1 ofs k p \/ ~ Mem.perm m1 b1 ofs Max Nonempty *) - -(* 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') *) -(* : *) -(* external_call_unknowns ef ge m' args. *) -(* Proof. *) -(* unfold external_call_unknowns in *. des_ifs. *) + Lemma public_rev_perm_delta_apply_inj + d ge m m_i m_i' + (PRP: public_rev_perm ge m m_i) + (APPD: mem_delta_apply_inj (meminj_public ge) d (Some m_i) = Some m_i') + : + public_rev_perm ge m m_i'. + Proof. + revert_until d. induction d; intros. + { ss; clarify. } + rewrite mem_delta_apply_inj_cons in APPD. des_ifs; clarify; eauto. + exploit mem_delta_apply_inj_some; eauto. intros (m1 & STORE). rewrite STORE in APPD. + eapply IHd; clear IHd. 2: eauto. + unfold public_rev_perm in *. intros. specialize (PRP b1). des_ifs. intros. + eapply PRP. 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) k d m_a0 m_i m @@ -855,7 +986,7 @@ Section PROOF. (exists k2, match_mem ge k2 [] m' m2 m' /\ Val.inject k2 res res') . Proof. - destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5). + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). (* reestablish meminj *) exploit mem_delta_apply_establish_inject; eauto. { apply meminj_public_strict. } @@ -867,13 +998,8 @@ Section PROOF. { 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 f' [] m' m_i'' m'). - { unfold match_mem. simpl. splits; auto. - { pose proof (meminj_not_alloc_delta _ _ MEM2 _ _ MEM5) as NALLOC. - 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. - } + { 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. @@ -882,38 +1008,37 @@ Section PROOF. destruct (Pos.ltb_spec b (Mem.nextblock m)); auto. specialize (NALLOC _ H0). congruence. } - constructor. + 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. - { clear - ECC MEMINJ'. admit. - -Mem.perm_drop_1: - forall (m : mem) (b : block) (lo hi : Z) (p : permission) (cp : compartment) (m' : mem), - Mem.drop_perm m b lo hi p cp = Some m' -> forall (ofs : Z) (k : perm_kind), (lo <= ofs < hi)%Z -> Mem.perm m' b ofs k p - -Genv.alloc_global = -fun (F V : Type) (CF : has_comp F) (ge : Genv.t F V) (m : mem) (idg : ident * globdef F V) => -let (_, g) := idg in -match g with -| Gfun f => let (m1, b) := Mem.alloc m (comp_of f) 0 1 in Mem.drop_perm m1 b 0 1 Nonempty (comp_of f) -| Gvar v => - let init := gvar_init v in - let comp := gvar_comp v in - let sz := init_data_list_size init in - let (m1, b) := Mem.alloc m comp 0 sz in - match store_zeros m1 b 0 sz comp with - | Some m2 => match Genv.store_init_data_list ge m2 b 0 init comp with - | Some m3 => Mem.drop_perm m3 b 0 sz (Genv.perm_globvar v) comp - | None => None - end - | None => None - end -end - : forall F V : Type, has_comp F -> Genv.t F V -> mem -> ident * globdef F V -> option mem - - - (* visible_fo *) } - Admitted. + { 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 @@ -952,7 +1077,7 @@ end 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). + 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. } @@ -974,7 +1099,7 @@ end 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. split; auto. } + { unfold match_mem. splits; auto. } } intros (btr & ist' & UTR & ISTAR'). exists btr, ist'. split; auto. @@ -992,23 +1117,23 @@ end (match_mem ge k d m_a0 m_i m') . Proof. - destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5). + 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. split; auto. + 1,2: econs; econs; eauto. unfold match_mem. splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. esplits; eauto. - 1,2: econs; econs; eauto. split; auto. + 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. split; auto. + 1,2: econs; eauto. unfold match_mem. splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL. esplits; eauto. - 1,2: econs; eauto. split; auto. + 1,2: econs; eauto. unfold match_mem. splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } Qed. @@ -1061,7 +1186,7 @@ end (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). + destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). (* take a step *) inv STEP. (* invalid *) @@ -1097,6 +1222,7 @@ end { simpl. econstructor. econstructor 1; eauto. } { simpl. right. econs; eauto. econs. econs; eauto. } { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. } + splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. exists ([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 |} (Some [])]). @@ -1112,6 +1238,7 @@ end { 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. } @@ -1125,6 +1252,7 @@ end { simpl. eauto. } { simpl. econstructor. auto. } { simpl. right. econs; eauto. econs. auto. } + splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. exists ([Bundle_call [Event_annot text [arg]] ef_id [val_to_eventval ge res] {| sig_args := [targ]; sig_res := targ; sig_cc := cc_default |} (Some [])]). @@ -1136,6 +1264,7 @@ end { simpl. econstructor. eauto. } { simpl. right. econs; eauto. econs. auto. } { simpl. auto. } + splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL. clarify. } @@ -1143,19 +1272,20 @@ end 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: split; auto. 2: eauto. econstructor 1. + 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: split; auto. 2: eauto. econstructor 1. + 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: split; auto. 2: eauto. econstructor 1. + 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_store (chunk, b0, (Ptrofs.unsigned 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. simpl. 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, m'. @@ -1169,6 +1299,9 @@ end econs; auto. simpl. auto. } { 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'. @@ -1179,6 +1312,7 @@ end { 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. } @@ -1191,12 +1325,13 @@ end 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: split; auto. 2: eauto. econstructor 1. + exists [], k, d, m_a0, m_i, m'. simpl. splits; auto. 2: unfold match_mem; splits; auto. 2: eauto. econstructor 1. } Qed. @@ -1222,7 +1357,7 @@ end (match_mem ge 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). + destruct MTST3 as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). destruct WFASM as [WFASM0 WFASM1]. exploit extcall_cases. eapply ECC. eauto. clear ECC. intros [ECU | [ECKO | ECKS]]. @@ -1246,6 +1381,7 @@ end { simpl. econstructor. econstructor 1; eauto. } { simpl. right. econs; eauto. econs. econs; eauto. } { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. } + splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. exists ([Bundle_builtin [Event_vstore chunk id ofs0 ev] (EF_vstore cp chunk) [EVptr_global id ofs0; ev] []]). @@ -1260,6 +1396,7 @@ end { 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. } @@ -1272,6 +1409,7 @@ end { simpl. eauto. } { simpl. econstructor. auto. } { simpl. right. econs; eauto. econs. auto. } + splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. exists ([Bundle_builtin [Event_annot text [arg]] (EF_annot_val cp kind text targ) [val_to_eventval ge vres] []]). @@ -1282,25 +1420,27 @@ end { simpl. econstructor. eauto. } { simpl. right. 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: split; auto. econstructor 1. + 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: split; auto. econstructor 1. + 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: split; auto. econstructor 1. + 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_store (chunk, b0, (Ptrofs.unsigned 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. simpl. 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. @@ -1314,6 +1454,9 @@ end econs; auto. simpl. auto. } { 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. @@ -1324,6 +1467,7 @@ end { 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. } @@ -1336,12 +1480,13 @@ end 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: split; auto. econstructor 1. + exists [], k, d, m_a0, m_i. simpl. splits; auto. 2: rr; splits; auto. econstructor 1. } Qed. @@ -1383,7 +1528,7 @@ end : 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). + 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. } @@ -1401,7 +1546,7 @@ end exploit asm_to_ir_step_external. 12: eapply STAR. 11: eapply NEXTF. 10: eapply NEXTPC. 9: eapply STEP. all: eauto. - { split; 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. @@ -1462,7 +1607,7 @@ end : 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). + 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. } @@ -1480,7 +1625,7 @@ end { inv WFIR1. simpl in *. auto. } { inv WFIR1. auto. } { unfold match_cur_regset. rewrite COMP. rewrite PC_RA. auto. } - { split; auto. } + { rr; splits; auto. } } intros (btr & ist' & UTR & ISTAR'). exists ((Bundle_return [Event_return (Genv.find_comp_ignore_offset ge (rs PC)) (Genv.find_comp ge (Vptr cur Ptrofs.zero)) res] res) :: btr), ist'. @@ -1525,7 +1670,7 @@ end : 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). + 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 *) @@ -1538,16 +1683,16 @@ end destruct fd. (** next is internal *) { exploit asm_to_ir_returnstate_nccc_internal. 2: eapply IH. - 11: eapply STAR0. 10: eapply STEP0. all: eauto. split; eauto. + 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. split; eauto. + 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. split; eauto. + 11: eapply STAR. 10: eapply STEP0. all: eauto. rr; splits; eauto. } Qed. @@ -1586,7 +1731,7 @@ end : 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). + 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. } @@ -1604,7 +1749,7 @@ end exploit asm_to_ir_step_external. 12: eapply STAR. 11: eapply NEXTF. 10: eapply NEXTPC. 9: eapply STEP. all: eauto. - { split; 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. @@ -1648,7 +1793,7 @@ end : 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). + 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 *) @@ -1661,16 +1806,16 @@ end destruct fd. (** next is internal *) { exploit asm_to_ir_returnstate_nccc_internal. 2: eapply IH. - 11: eapply STAR0. 10: eapply STEP0. all: eauto. split; eauto. + 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. split; eauto. + 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. split; eauto. + 11: eapply STAR. 10: eapply STEP0. all: eauto. rr; splits; eauto. } Qed. @@ -1721,7 +1866,7 @@ end } 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). + 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. eapply MEM4. eapply MEM5. intros (d' & MEM4' & MEM5'). destruct f0. @@ -1737,7 +1882,10 @@ end rewrite H1. auto. } split. auto. - { unfold match_mem. repeat (split; auto). eapply public_not_freeable_exec_instr. 3: eapply H3. all: auto. eapply meminj_not_alloc_delta; eauto. } + { unfold match_mem. splits; auto. + eapply public_not_freeable_exec_instr. 3: eapply H3. all: auto. eapply meminj_not_alloc_delta; eauto. + eapply public_rev_perm_exec_instr. 3: eapply H3. all: auto. + } } exploit IH. 4: eapply STAR. 3: apply WFASM'. 3: eapply MTST'. all: auto. } @@ -1756,6 +1904,7 @@ end } { instantiate (4:=k). instantiate (3:=d'). unfold match_mem. splits; eauto. eapply public_not_freeable_exec_instr; eauto. eapply meminj_not_alloc_delta; eauto. + 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. From f20c4b049763672ad668e76c9cd7e9f00a0509da Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 4 Aug 2023 17:34:34 +0200 Subject: [PATCH 102/174] proved asm2ir init conds --- security/BtInfoAsm.v | 102 ++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 101 insertions(+), 1 deletion(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 5440529987..9316866623 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -395,7 +395,7 @@ Section CONDS. 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 => False + | None => True end. End CONDS. @@ -2197,3 +2197,103 @@ Section PROOF. 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 {F V} (p: AST.program (AST.fundef F) V) := *) + (* 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) /\ (fn_sig f = signature_main)). *) + 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. + (* unfold fundef in *. *) + exists (Some (b, m0, [])). econs; eauto. + Qed. + + Lemma match_state_initial_state + p ast ist + (* (WFMAIN: wf_main p) *) + (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. + From c2845ced14748407a877f3b51c8ada0fed0bc16f Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 4 Aug 2023 17:38:59 +0200 Subject: [PATCH 103/174] some cleanups --- Makefile | 2 +- security/BtFromAsm.v | 483 ------------------------------------------- 2 files changed, 1 insertion(+), 484 deletions(-) delete mode 100644 security/BtFromAsm.v diff --git a/Makefile b/Makefile index 4abe50ca68..eb98c8c0c5 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 Tactics.v MemoryWeak.v MemoryDelta.v BtInfoAsm.v BtBasics.v BtFromAsm.v Backtranslation.v +SECURITY=RSC.v Split.v Blame.v Recomposition.v Tactics.v MemoryWeak.v MemoryDelta.v BtInfoAsm.v BtBasics.v Backtranslation.v # Parser diff --git a/security/BtFromAsm.v b/security/BtFromAsm.v deleted file mode 100644 index 065aa3d73c..0000000000 --- a/security/BtFromAsm.v +++ /dev/null @@ -1,483 +0,0 @@ -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.Asm. -Require Import BtBasics. - - -Section WELLFORMED. - - (* Variant sf_cont_type : Type := | sf_cont: block -> signature -> sf_cont_type. *) - Variant sf_cont_type : Type := | sf_cont: block -> sf_cont_type. - Definition sf_conts := list sf_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 virtual_reality (ct: Genv.call_type) (vr: real_virtual): Prop := - match ct with - | Genv.InternalCall => False - | Genv.CrossCompartmentCall => vr = is_real - | Genv.DefaultCompartmentCall => vr = is_virtual - end. - - (* wf_sem: from asm, wf_st: proof invariant for Clight states *) - Inductive info_asm_sem_wf (ge: Asm.genv) : block -> mem -> sf_conts -> itrace -> Prop := - | info_asm_sem_wf_base - cur m1 sf - : - info_asm_sem_wf ge cur m1 sf nil - | info_asm_sem_wf_cross_call - cur m1 sf ev ik vr tl - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - cp' fid evargs - (EV: ev = Event_call cp cp' fid evargs) - sg - (IK: ik = info_call not_cross_ext sg vr) - b - (FINDB: Genv.find_symbol ge fid = Some b) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (CP': cp' = comp_of fd) - (VR: virtual_reality (Genv.type_of_call ge cp cp') vr) - (* (CROSS: Genv.type_of_call ge cp cp' <> Genv.InternalCall) *) - args - (NPTR: crossing_comp ge cp cp' -> Forall not_ptr args) - (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) - (ESM: crossing_comp ge cp cp' -> eventval_list_match ge evargs (sig_args sg) args) - (SIG: sg = Asm.funsig fd) - (NEXT: info_asm_sem_wf ge b m1 ((sf_cont cur) :: sf) tl) - : - info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) - | info_asm_sem_wf_cross_return_internal - cur m1 ev ik vr tl - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - cp_c evres - (EV: ev = Event_return cp_c cp evres) - sg - (IK: ik = info_return sg vr) - cur_f - (INTERNAL: Genv.find_funct_ptr ge cur = Some (AST.Internal cur_f)) - (* Follows from cross call - stack has the sig *) - (SIG: sg = Asm.fn_sig cur_f) - (VR: virtual_reality (Genv.type_of_call ge cp_c cp) vr) - res - (EVM: crossing_comp ge cp_c cp -> eventval_match ge evres (proj_rettype (sig_res sg)) res) - (NPTR: crossing_comp ge cp_c cp -> not_ptr res) - b_c sf_tl - (CPC: cp_c = Genv.find_comp ge (Vptr b_c Ptrofs.zero)) - (* internal return: memory changes in Clight-side, so need inj-relation *) - (NEXT: info_asm_sem_wf ge b_c m1 sf_tl tl) - : - info_asm_sem_wf ge cur m1 ((sf_cont b_c) :: sf_tl) ((ev, ik) :: tl) - | info_asm_sem_wf_intra_call_external - cur m1 sf ev ik tl - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - ef res m2 - (EXTEV: external_call_event_match_common ef ev ge cp m1 res m2) - fb - (IK: ik = info_external fb (ef_sig ef)) - fid - (INV: Genv.invert_symbol ge fb = Some fid) - (ISEXT: Genv.find_funct_ptr ge fb = Some (AST.External ef)) - (ALLOWED: Genv.allowed_call ge cp (Vptr fb Ptrofs.zero)) - (INTRA: Genv.type_of_call ge cp (Genv.find_comp ge (Vptr fb Ptrofs.zero)) = Genv.InternalCall) - (NEXT: info_asm_sem_wf ge cur m2 sf tl) - : - info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) - | info_asm_sem_wf_builtin - cur m1 sf ev ik tl - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - ef res m2 - (EXT: external_call_event_match_common ef ev ge cp m1 res m2) - (IK: ik = info_builtin ef) - (NEXT: info_asm_sem_wf ge cur m2 sf tl) - : - info_asm_sem_wf ge cur m1 sf ((ev, ik) :: tl) - | info_asm_sem_wf_cross_call_external1 - (* early cut at call event *) - cur m1 sf ev vr ik - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - cp' fid evargs - (EV: ev = Event_call cp cp' fid evargs) - sg - (IK: ik = info_call is_cross_ext sg vr) - b - (FINDB: Genv.find_symbol ge fid = Some b) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (CP': cp' = comp_of fd) - (VR: virtual_reality (Genv.type_of_call ge cp cp') vr) - args - (NPTR: crossing_comp ge cp cp' -> Forall not_ptr args) - (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) - (ESM: crossing_comp ge cp cp' -> eventval_list_match ge evargs (sig_args sg) args) - ef - (EXTERNAL: fd = AST.External ef) - (SIG: sg = ef_sig ef) - : - info_asm_sem_wf ge cur m1 sf ((ev, ik) :: nil) - | info_asm_sem_wf_cross_call_external2 - (* early cut at call-ext_call event *) - cur m1 sf ev1 vr1 ik1 - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - cp' fid evargs - (EV: ev1 = Event_call cp cp' fid evargs) - sg - (IK: ik1 = info_call is_cross_ext sg vr1) - b - (FINDB: Genv.find_symbol ge fid = Some b) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (CP': cp' = comp_of fd) - (VR: virtual_reality (Genv.type_of_call ge cp cp') vr1) - args - (NPTR: crossing_comp ge cp cp' -> Forall not_ptr args) - (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) - (ESM: crossing_comp ge cp cp' -> eventval_list_match ge evargs (sig_args sg) args) - ef - (EXTERNAL: fd = AST.External ef) - (SIG: sg = ef_sig ef) - (* external call part *) - tr vres m2 - (EXTCALL: external_call ef ge cp args m1 tr vres m2) - itr - (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) - : - info_asm_sem_wf ge cur m1 sf ((ev1, ik1) :: itr) - | info_asm_sem_wf_cross_call_external3 - (* full call-ext_call-return event *) - cur m1 sf ev1 vr1 ik1 - cp - (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) - cp' fid evargs - (EV: ev1 = Event_call cp cp' fid evargs) - sg - (IK: ik1 = info_call is_cross_ext sg vr1) - b - (FINDB: Genv.find_symbol ge fid = Some b) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (CP': cp' = comp_of fd) - (VR1: virtual_reality (Genv.type_of_call ge cp cp') vr1) - args - (NPTR: crossing_comp ge cp cp' -> Forall not_ptr args) - (ALLOW: Genv.allowed_call ge cp (Vptr b Ptrofs.zero)) - (ESM: crossing_comp ge cp cp' -> eventval_list_match ge evargs (sig_args sg) args) - ef - (EXTERNAL: fd = AST.External ef) - (SIG: sg = ef_sig ef) - (* external call part *) - tr vres m2 - (EXTCALL: external_call ef ge cp args m1 tr vres m2) - itr - (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) - (* return part *) - ev3 vr3 ik3 tl - evres - (EV: ev3 = Event_return cp cp' evres) - sg - (IK: ik3 = info_return sg vr3) - (VR2: virtual_reality (Genv.type_of_call ge cp cp') vr3) - (EVM: crossing_comp ge cp cp' -> eventval_match ge evres (proj_rettype (sig_res sg)) vres) - (NPTR: crossing_comp ge cp cp' -> not_ptr vres) - (NEXT: info_asm_sem_wf ge cur m2 sf tl) - : - info_asm_sem_wf ge cur m1 sf ((ev1, ik1) :: (itr ++ ((ev3, ik3) :: tl))) - . - - (* TODO *) - (* we need a more precise invariant for the proof; counters, mem_inj, env, cont, state *) - -End WELLFORMED. - -Section MATCH. - - Variant match_stack_type : (sf_cont_type) -> (stackframe) -> Prop := - | match_stack_type_intro - b cp sg v ofs - (* needs to talk about sig in stack *) - : - match_stack_type (sf_cont b) (Stackframe b cp sg v ofs). - - Definition match_stack (sf: sf_conts) (st: stack) := Forall2 match_stack_type sf st. - - Definition match_cp (ge: Asm.genv) (cur: block) (cp: compartment) : Prop := - Genv.find_comp ge (Vptr cur Ptrofs.zero) = cp. - - Definition meminj_ge {F V} (ge: Genv.t F V): meminj := - fun b => match Genv.invert_symbol ge b with - | Some id => match Genv.find_symbol ge id with - | Some b' => Some (b', 0) - | None => None - end - | None => None - end. - - Definition match_mem (ge: Asm.genv) (m_ir m_asm: mem): Prop := Mem.inject (meminj_ge ge) m_asm m_ir. - - 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_stack (ge: Asm.genv) (rs: regset) := - match rs PC with - | Vptr b _ => match Genv.find_funct_ptr ge b with - | Some (External ef) => False - | _ => True - end - | _ => True - end. - - (* Definition wf_regset_stack cpm (ge: Asm.genv) (rs: regset) (sk: stack) := *) - (* match rs PC with *) - (* | Vptr b _ => match Genv.find_funct_ptr ge b with *) - (* | Some (External ef) => Genv.find_comp_ignore_offset ge (rs RA) = callee_comp cpm sk *) - (* | _ => True *) - (* end *) - (* | _ => True *) - (* end. *) - - - -(* Definition external_call_mem_inject_gen ef := ec_mem_inject (external_call_spec ef). *) - -(* external_call_mem_inject: *) -(* forall (ef : external_function) [F V : Type] [ge : Genv.t F V] (c : compartment) [vargs : list val] [m1 : mem] (t : trace) (vres : val) (m2 : mem) [f : block -> option (block * Z)] *) -(* [m1' : mem] [vargs' : list val], *) -(* meminj_preserves_globals ge f -> *) -(* external_call ef ge c vargs m1 t vres m2 -> *) -(* Mem.inject f m1 m1' -> *) -(* Val.inject_list f vargs vargs' -> *) -(* exists (f' : meminj) (vres' : val) (m2' : mem), *) -(* external_call ef ge c vargs' m1' t vres' m2' /\ *) -(* Val.inject f' vres vres' /\ Mem.inject f' m2 m2' /\ Mem.unchanged_on (loc_unmapped f) m1 m2 /\ Mem.unchanged_on (loc_out_of_reach f m1) m1' m2' /\ inject_incr f f' /\ inject_separated f f' m1 m1' *) - -(* meminj_preserves_globals: forall [F V : Type], Genv.t F V -> (block -> option (block * Z)) -> Prop *) -(* Separation.globalenv_preserved: forall {F V : Type}, Genv.t F V -> meminj -> block -> Prop *) -(* Genv.same_symbols: forall [F V : Type], meminj -> Genv.t F V -> Prop *) -(* Genv.init_mem p = Some m0 -> *) -(* Variable f: block -> option (block * Z). *) -(* Variable ge1 ge2: Senv.t. *) - -(* Definition symbols_inject : Prop := *) -(* (forall id, Senv.public_symbol ge2 id = Senv.public_symbol ge1 id) *) -(* /\ (forall id b1 b2 delta, *) -(* f b1 = Some(b2, delta) -> Senv.find_symbol ge1 id = Some b1 -> *) -(* delta = 0 /\ Senv.find_symbol ge2 id = Some b2) *) -(* /\ (forall id b1, *) -(* Senv.public_symbol ge1 id = true -> Senv.find_symbol ge1 id = Some b1 -> *) -(* exists b2, f b1 = Some(b2, 0) /\ Senv.find_symbol ge2 id = Some b2) *) -(* /\ (forall b1 b2 delta, *) -(* f b1 = Some(b2, delta) -> *) -(* Senv.block_is_volatile ge2 b2 = Senv.block_is_volatile ge1 b1). *) -(* Senv.equiv = *) -(* fun se1 se2 : Senv.t => *) -(* (forall id : ident, Senv.find_symbol se2 id = Senv.find_symbol se1 id) /\ *) -(* (forall id : ident, Senv.public_symbol se2 id = Senv.public_symbol se1 id) /\ (forall b : block, Senv.block_is_volatile se2 b = Senv.block_is_volatile se1 b) *) -(* : Senv.t -> Senv.t -> Prop *) - -End MATCH. - -Section PROOF. - - 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. - - (* If main is External, treat it in a different case - the trace can start with Event_syscall, without a preceding Event_call *) - Lemma from_info_asm_sem_wf - cpm ge s s' it - (WFGE: wf_ge ge) - (STAR: istar (asm_istep cpm) ge s it s') - sk rs m - (STATE: s = State sk rs m) - (WFSK: wf_stack ge sk) - (WFRS: wf_regset_stack ge rs) - (* (WFRS: wf_regset_stack cpm ge rs sk) *) - cur m_ir k - (MC: match_cp ge cur (Genv.find_comp_ignore_offset ge (rs PC))) - (MM: match_mem ge m_ir m) - (MS: match_stack k sk) - : - info_asm_sem_wf ge cur m_ir k it. - Proof. - apply measure_istar in STAR. destruct STAR as (n & STAR). - move n before ge. revert s s' it WFGE STAR sk rs m STATE WFSK WFRS cur m_ir k MC MM MS. - pattern n. apply (well_founded_induction Nat.lt_wf_0). intros m IH. intros. - inv STAR; subst. - { constructor 1. } - rename H0 into STAR. inv H; simpl. - - assert (INTRA: Genv.find_comp ge (Vptr cur Ptrofs.zero) = Genv.find_comp_ignore_offset ge (rs' PC)). - { rewrite MC. rewrite NEXTPC, <- ALLOWED. unfold Genv.find_comp_ignore_offset. rewrite H3. unfold Genv.find_comp. rewrite Genv.find_funct_find_funct_ptr. rewrite H4. auto. } - destruct (Genv.find_funct_ptr ge b') eqn:NEXTFUN. destruct f0. - + eapply IH; try reflexivity. 3: eauto. all: auto. - { unfold wf_regset_stack. rewrite NEXTPC, NEXTFUN. auto. } - { admit. (* mem *) } - + (* intra -> external *) - inv STAR. - { constructor 1. } - inv H. all: rewrite NEXTPC in H8; inv H8; rewrite NEXTFUN in H11; inv H11. - inv H0. - { (* trace ends *) - exploit external_call_trace_length. eauto. intros EVLEN. destruct t. - - simpl. constructor 1. - - destruct t; simpl in EVLEN. 2: lia. clear EVLEN. - simpl. pose proof NEXTFUN as NF0. unfold Genv.find_funct_ptr in NF0. destruct (Genv.find_def ge b0) eqn:FDB0; [|inv NF0]. destruct g; inv NF0. - exploit wf_ge_block_to_id; eauto. intros (fid & INV). - econstructor 4; try reflexivity; auto. - { admit. (* ext call sem *) } - { eauto. } - { unfold Genv.allowed_call. right; left. rewrite <- NEXTPC. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. auto. } - { unfold Genv.type_of_call. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. rewrite Pos.eqb_refl. auto. } - { constructor 1. } - } - inv H. - (* replace ((set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (rs' X1) PC) with (rs' X1) in *. *) - (* 2:{ rewrite Pregmap.gss. auto. } *) - destruct (Pos.eqb_spec (callee_comp cpm sk) (Genv.find_comp_ignore_offset ge ((set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs')) # PC <- (rs' X1) PC))). - { (* intra-return *) - clear PC_RA RESTORE_SP NO_CROSS_PTR. pose proof EV as RETEV. inv RETEV; simpl. - 2:{ exfalso. unfold Genv.type_of_call in H. rewrite <- e in H. rewrite Pos.eqb_refl in H. inv H. } - 2:{ exfalso. unfold Genv.type_of_call in H. rewrite <- e in H. rewrite Pos.eqb_refl in H. inv H. } - assert (STK: st' = sk). - { unfold update_stack_return in STUPD. rewrite <- e in STUPD. rewrite Pos.eqb_refl in STUPD. inv STUPD. auto. } - subst st'. simpl in INFO; subst. simpl. - pose proof H1 as IH_ISTAR. move IH_ISTAR after H1. inv H1. - { (* trace ends *) - exploit external_call_trace_length. eauto. intros EVLEN. destruct t. - { simpl. clear EVLEN. constructor 1. } - destruct t; simpl in EVLEN. 2: lia. clear EVLEN. - pose proof NEXTFUN as NF0. unfold Genv.find_funct_ptr in NF0. destruct (Genv.find_def ge b0) eqn:FDB0; [|inv NF0]. destruct g; inv NF0. - exploit wf_ge_block_to_id. eauto. eapply FDB0. intros (fid & INV). - eapply info_asm_sem_wf_intra_call_external; eauto. - { admit. (* ext call sem *) } - { unfold Genv.allowed_call. right; left. rewrite <- NEXTPC. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. auto. } - { unfold Genv.type_of_call. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. rewrite Pos.eqb_refl. auto. } - { constructor 1. } - } - (* now we case-analysis new PC = (rs' X1) *) - destruct (val_is_ptr_or_not (rs' X1)). - { (* not a Vptr, so booms for every step *) - rename H1 into NP. clear - H0 NP. inv H0; exfalso. all: rewrite Pregmap.gss in H3; eapply NP; eauto. - } - destruct H1 as (b2 & ofs2 & NEXTPC2). destruct (Genv.find_funct_ptr ge b2) eqn:NEXTFUN2. destruct f0. - { (* next fun is internal - done by induction *) - exploit external_call_trace_length. eauto. intros EVLEN. destruct t; simpl. - { clear EVLEN. - eapply IH. 3: eapply IH_ISTAR. all: auto. - - red. rewrite Pregmap.gss. rewrite NEXTPC2. rewrite NEXTFUN2. auto. - - rewrite Pregmap.gss in *. rewrite <- e. rewrite <- REC_CURCOMP. auto. - - admit. (* mem -> need to execute external call to maintain injection? *) - } - destruct t; simpl in *. 2:lia. clear EVLEN. - pose proof NEXTFUN as NF0. unfold Genv.find_funct_ptr in NF0. destruct (Genv.find_def ge b0) eqn:FDB0; [|inv NF0]. destruct g; inv NF0. - exploit wf_ge_block_to_id. eauto. eapply FDB0. intros (fid & INV). - eapply info_asm_sem_wf_intra_call_external; eauto. - { admit. (* ext call sem *) } - { unfold Genv.allowed_call. right; left. rewrite <- NEXTPC. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. auto. } - { unfold Genv.type_of_call. rewrite INTRA. unfold Genv.find_comp_ignore_offset, Genv.find_comp. rewrite NEXTPC. rewrite Pos.eqb_refl. auto. } - eapply IH. 3: eapply IH_ISTAR. all: auto. - - red. rewrite Pregmap.gss. rewrite NEXTPC2. rewrite NEXTFUN2. auto. - - rewrite Pregmap.gss in *. rewrite <- e. rewrite <- REC_CURCOMP. auto. - - admit. (* mem *) - } - { (* next fun is external; undef_caller_save_regs sets RA=Vundef, so we take extcall-step, which sets PC=RA, and after the return step, we have PC=Vundef. *) - (* TODO *) - - - - - - - constructor 1. } - - - - - - - - exploit external_call_trace_length. eauto. intros EVLEN. destruct t. - { simpl. clear EVLEN. eapply IH. 3: eapply H1. all: auto. - - red. rewrite Pregmap.gss. - (* TODO *) - - pose proof EV as RETEV. inv RETEV; simpl. - { eapply IH. 3: eauto. all: auto. - assert (STEQ: st' = sk). - - { unfold update_stack_return in STUPD. - econstructor 4. - - (* TODO *) - - eapply IHSTAR. - - -istar_ind: - forall (genv state : Type) (step : genv -> state -> itrace -> state -> Prop) (ge : genv) (P : state -> itrace -> state -> Prop), - (forall s : state, P s nil s) -> - (forall (s1 : state) (t1 : itrace) (s2 : state) (t2 : itrace) (s3 : state) (t : itrace), step ge s1 t1 s2 -> istar step ge s2 t2 s3 -> P s2 t2 s3 -> t = t1 ++ t2 -> P s1 t s3) -> - forall (y : state) (i : itrace) (y0 : state), istar step ge y i y0 -> P y i y0 - - - -external_call_trace_length: - forall (ef : external_function) (ge : Senv.t) (c : compartment) (vargs : list val) (m : mem) (t : trace) (vres : val) (m' : mem), external_call ef ge c vargs m t vres m' -> (Datatypes.length t <= 1)%nat - - - - - (* TODO *) - - Inductive info_asm_sem_wf (ge: Asm.genv) : block -> mem -> sf_conts -> itrace -> Prop := - Definition state_has_trace_informative (L: Smallstep.semantics) (s: state L) (step: istep L) (t: itrace): Prop := - (exists s', (istar step (globalenv L)) s t s'). - Variant semantics_has_initial_trace_informative (L: Smallstep.semantics) (step: istep L) (t: itrace) : Prop := - | semantics_info_runs : - forall s, (initial_state L s) -> (state_has_trace_informative L s step t) -> semantics_has_initial_trace_informative _ _ t - | semantics_info_goes_initially_wrong : (forall s : state L, ~ initial_state L s) -> (t = nil) -> semantics_has_initial_trace_informative _ _ t. - Definition asm_has_initial_trace_informative (p: Asm.program) (t: itrace) := - semantics_has_initial_trace_informative (semantics p) (asm_istep (comp_of_main p)) t. - -Mem.alloc_left_unmapped_inject: - forall (f : meminj) (m1 m2 : mem) (c : compartment) (lo hi : Z) (m1' : Mem.mem') (b1 : block), - Mem.inject f m1 m2 -> Mem.alloc m1 c lo hi = (m1', b1) -> exists f' : meminj, Mem.inject f' m1' m2 /\ inject_incr f f' /\ f' b1 = None /\ (forall b : block, b <> b1 -> f' b = f b) - -Mem.free_left_inject: forall (f : meminj) (m1 m2 : mem) (b : block) (lo hi : Z) (cp : compartment) (m1' : mem), Mem.inject f m1 m2 -> Mem.free m1 b lo hi cp = Some m1' -> Mem.inject f m1' m2 - -Mem.free_right_inject: - forall (f : meminj) (m1 m2 : mem) (b : block) (lo hi : Z) (cp : compartment) (m2' : mem), - Mem.inject f m1 m2 -> - Mem.free m2 b lo hi cp = Some m2' -> - (forall (b1 : block) (delta ofs : Z) (k : perm_kind) (p : permission), f b1 = Some (b, delta) -> Mem.perm m1 b1 ofs k p -> lo <= ofs + delta < hi -> False) -> Mem.inject f m1 m2' - -End PROOF. From 245cd3592c0e6018a67195da21c81eabe80c214a Mon Sep 17 00:00:00 2001 From: ldj Date: Sun, 6 Aug 2023 21:56:38 +0200 Subject: [PATCH 104/174] WIP --- security/Backtranslation.v | 203 ++----------------------------------- 1 file changed, 11 insertions(+), 192 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index fac1cda666..0ad7f888a5 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -5,193 +5,9 @@ Require Import AST Linking Smallstep Events Behaviors. Require Import Split. Require Import riscV.Asm. -Require Import BtInfoAsm BtBasics BtFromAsm. +Require Import BtBasics BtInfoAsm MemoryDelta. Require Import Ctypes Clight. - -(* Record syscall_properties (sem: extcall_sem) (sg: signature) : Prop := *) -(* mk_syscall_properties { *) -(* sc_args_match: *) -(* forall ge cp args m1 name evargs evres res m2, *) -(* sem ge cp args m1 (Event_syscall name evargs evres :: nil) res m2 -> *) -(* eventval_list_match ge evargs sg.(sig_args) args; *) -(* }. *) - - -(* Section GENV. *) - -(* Context {F: Type}. *) -(* Context {V: Type}. *) - -(* (* For NR, use below: *) *) -(* (* ::: mkpass Unusedglobproof.match_prog *) *) -(* (* match_prog_unique: *) *) -(* (* list_norepet (prog_defs_names tp) *) *) -(* 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.perm m1' b ofs Cur Writable -> *) *) -(* 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). *) -(* (* eapply Mem.perm_implies; eauto. constructor. *) *) -(* 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. *) - -(* (* Record unchanged_on (P : block -> Z -> Prop) (m_before m_after : mem) : Prop := mk_unchanged_on *) *) -(* (* { unchanged_on_nextblock : Ple (Mem.nextblock m_before) (Mem.nextblock m_after); *) *) -(* (* unchanged_on_perm : forall (b : block) (ofs : Z) (k : perm_kind) (p : permission), P b ofs -> Mem.valid_block m_before b -> Mem.perm m_before b ofs k p <-> Mem.perm m_after b ofs k p; *) *) -(* (* unchanged_on_contents : forall (b : block) (ofs : Z), P b ofs -> Mem.perm m_before b ofs Cur Readable -> ZMap.get ofs (Mem.mem_contents m_after) !! b = ZMap.get ofs (Mem.mem_contents m_before) !! b; *) *) -(* (* unchanged_on_own : forall (b : block) (cp : option compartment), Mem.valid_block m_before b -> Mem.can_access_block m_before b cp <-> Mem.can_access_block m_after b cp }. *) *) - -(* 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. *) - -(* (* *) -(* forall b, b is the block of one of the counter -> *) -(* (forall b0 ofs, ~ (f b0 = Some (b, ofs))) *) -(* *) *) - -(* (** Events.v **) *) -(* (* (** External calls must commute with memory injections, *) *) -(* (* in the following sense. *) *) *) -(* (* ec_mem_inject: *) *) -(* (* forall ge1 ge2 c vargs m1 t vres m2 f m1' vargs', *) *) -(* (* symbols_inject f ge1 ge2 -> *) *) -(* (* sem ge1 c vargs m1 t vres m2 -> *) *) -(* (* Mem.inject f m1 m1' -> *) *) -(* (* Val.inject_list f vargs vargs' -> *) *) -(* (* exists f', exists vres', exists m2', *) *) -(* (* sem ge2 c vargs' m1' t vres' m2' *) *) -(* (* /\ Val.inject f' vres vres' *) *) -(* (* /\ Mem.inject f' m2 m2' *) *) -(* (* /\ Mem.unchanged_on (loc_unmapped f) m1 m2 *) *) -(* (* /\ Mem.unchanged_on (loc_out_of_reach f m1) m1' m2' *) *) -(* (* /\ inject_incr f f' *) *) -(* (* /\ inject_separated f f' m1 m1'; *) *) - -(* End MEM. *) - - Section Backtranslation. Ltac simpl_expr := @@ -401,6 +217,13 @@ Section Backtranslation. | 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 @@ -453,12 +276,6 @@ Section Backtranslation. wf_eventval_pub v -> wf_eventval_ge v. Proof. intros H. destruct v; simpl in *; auto. apply Genv.public_symbol_exists in H; auto. Qed. - 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 list_eventval_to_list_expr (vs: list eventval): list expr := List.map eventval_to_expr vs. @@ -474,7 +291,7 @@ Section Backtranslation. Section CODEAUX. (* We extract function data: argument types, fn_return, rn_callconv from signature *) - (* Correctness should follow from the semantics of Asm, especially eventval_match *) + (* Correctness should follow from eventval_match *) Definition typ_to_type: typ -> type := fun t: typ => match t with @@ -596,6 +413,8 @@ Section Backtranslation. Section CODE. (** converting *informative* trace to code **) + (* TODO *) + Context {F: Type}. Context {V: Type}. Variable ge: Genv.t F V. From 695af1fcc385c3a090f7246e7d4572feacffff89 Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 7 Aug 2023 16:56:01 +0200 Subject: [PATCH 105/174] WIP --- security/BtInfoAsm.v | 29 ++++++++++++++--------------- 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 9316866623..de222c82ca 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -250,7 +250,7 @@ Section IR. 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)) + (external_call_known_observables ef ge m1' vargs tr vretv m2 /\ d = [])) (ARGS: evargs = vals_to_eventvals ge vargs) : ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg (Some d)) (Some (cur, m2, ik)) @@ -264,7 +264,7 @@ Section IR. 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)) + (external_call_known_observables ef ge m1' vargs tr vretv m2 /\ d = [])) (ARGS: evargs = vals_to_eventvals ge vargs) : ir_step ge (Some (cur, m1, ik)) (Bundle_builtin tr ef evargs d) (Some (cur, m2, ik)) @@ -304,7 +304,7 @@ Section IR. 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)) + (external_call_known_observables ef ge m1' vargs tr2 vretv m2 /\ d = [])) (ARGS: evargs = vals_to_eventvals ge vargs) : ir_step ge (Some (cur, m1, ik)) (Bundle_call (tr1 ++ tr2) id evargs sg (Some d)) None @@ -328,7 +328,7 @@ Section IR. 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)) + (external_call_known_observables ef ge m1' vargs tr2 vretv m2 /\ d = [])) (ARGS: evargs = vals_to_eventvals ge vargs) (* return part *) tr3 evretv @@ -1148,13 +1148,13 @@ Section PROOF. exists d' m1 m2 res', (mem_delta_apply_inj (meminj_public ge) 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)) /\ + ((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 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. instantiate (1:=[]); ss. + - exploit match_mem_external_call_establish2; eauto. intros. des. esplits; eauto. ss. Qed. Lemma asm_to_ir_step_external @@ -1220,7 +1220,7 @@ Section PROOF. { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } { simpl. eauto. } { simpl. econstructor. econstructor 1; eauto. } - { simpl. right. econs; eauto. econs. econs; eauto. } + { simpl. right. split; auto. econs; eauto. econs. econs; eauto. } { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. } splits; auto. } @@ -1234,7 +1234,7 @@ Section PROOF. { instantiate (2:=[Vptr b0 ofs; Val.load_result chunk v]). simpl. econstructor. econstructor 1; eauto. rewrite val_load_result_idem. auto. } - { simpl. right. econs; eauto. econs. econs; eauto. rewrite val_load_result_idem. auto. } + { simpl. right. split; auto. econs; eauto. econs. econs; eauto. 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. } @@ -1251,7 +1251,7 @@ Section PROOF. { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } { simpl. eauto. } { simpl. econstructor. auto. } - { simpl. right. econs; eauto. econs. auto. } + { simpl. right. split; auto. econs; eauto. econs. auto. } splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. @@ -1262,7 +1262,7 @@ Section PROOF. { rewrite CURCOMP, <- REC_CURCOMP, NEXTPC. simpl. unfold Genv.find_comp. setoid_rewrite NEXTF. unfold Genv.type_of_call. rewrite Pos.eqb_refl. auto. } { simpl. eauto. } { simpl. econstructor. eauto. } - { simpl. right. econs; eauto. econs. auto. } + { simpl. right. split; auto. econs; eauto. econs. auto. } { simpl. auto. } splits; auto. } @@ -1379,7 +1379,7 @@ Section PROOF. eapply ir_step_builtin. all: eauto. { simpl. eauto. } { simpl. econstructor. econstructor 1; eauto. } - { simpl. right. econs; eauto. econs. econs; eauto. } + { simpl. right. split; auto. econs; eauto. econs. econs; eauto. } { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. } splits; auto. } @@ -1392,7 +1392,7 @@ Section PROOF. { instantiate (2:=[Vptr b0 ofs0; Val.load_result chunk v]). simpl. econstructor. econstructor 1; eauto. rewrite val_load_result_idem. auto. } - { simpl. right. econs; eauto. econs. econs; eauto. rewrite val_load_result_idem. auto. } + { simpl. right. split; auto. econs; eauto. econs. econs; eauto. 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. } @@ -1408,7 +1408,7 @@ Section PROOF. eapply ir_step_builtin. all: eauto. { simpl. eauto. } { simpl. econstructor. auto. } - { simpl. right. econs; eauto. econs. auto. } + { simpl. right. split; auto. econs; eauto. econs. auto. } splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. @@ -1418,7 +1418,7 @@ Section PROOF. eapply ir_step_builtin. all: eauto. { simpl. eauto. } { simpl. econstructor. eauto. } - { simpl. right. econs; eauto. econs. auto. } + { simpl. right. split; auto. econs; eauto. econs. auto. } { simpl. auto. } splits; auto. } @@ -2296,4 +2296,3 @@ Section INIT. Qed. End INIT. - From e74ca1e0b147dd2ac518abcd5c974f4804febe97 Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 7 Aug 2023 18:41:22 +0200 Subject: [PATCH 106/174] WIP --- security/Backtranslation.v | 88 ++++++++++++++++++++++++++++++++++++-- 1 file changed, 84 insertions(+), 4 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 0ad7f888a5..189f054fb5 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -4,6 +4,7 @@ Require Import AST Linking Smallstep Events Behaviors. Require Import Split. +Require Import Tactics. Require Import riscV.Asm. Require Import BtBasics BtInfoAsm MemoryDelta. Require Import Ctypes Clight. @@ -300,8 +301,8 @@ Section Backtranslation. | AST.Tlong => Tlong Signed noattr | AST.Tsingle => Tfloat F32 noattr (* do not appear in eventval_match *) - | AST.Tany32 => Tvoid - | AST.Tany64 => Tvoid + | AST.Tany32 => Tint I32 Signed noattr + | AST.Tany64 => Tlong Signed noattr end. Fixpoint list_typ_to_typelist (ts: list typ): typelist := @@ -410,15 +411,94 @@ Section Backtranslation. End CODEAUX. + Section CONVVAL. + + Context {F: Type}. + Context {V: Type}. + Variable ge: Genv.t F V. + + Definition val_to_expr (v: val) : expr := + match v with + | Vint i => Econst_int i (Tint I32 Signed noattr) + | Vlong i => Econst_long i (Tlong Signed noattr) + | Vfloat f => Econst_float f (Tfloat F64 noattr) + | Vsingle f => Econst_single f (Tfloat F32 noattr) + | Vptr b ofs => let id := senv_invert_symbol_total ge b in ptr_of_id_ofs id ofs + | Vundef => Econst_int Int.zero (Tint I32 Signed noattr) + end. + + End CONVVAL. + + Section CODE. (** converting *informative* trace to code **) - (* TODO *) - Context {F: Type}. Context {V: Type}. Variable ge: Genv.t F V. + (* Type: Tvoid has size 1, which is what we want *) + Definition expr_of_addr (id: ident) (ofs: Z): expr := + ptr_of_id_ofs id (Ptrofs.repr ofs). + + Definition chunk_to_type (ch: memory_chunk): type := + match ch with + | Mint8signed => Tint I8 Signed noattr + | Mint8unsigned => Tint I8 Unsigned noattr + | Mint16signed =>Tint I16 Signed noattr + | Mint16unsigned =>Tint I16 Unsigned noattr + | Mint32 => Tint I32 Signed noattr + | Mint64 => Tlong Signed noattr + | Mfloat32 => Tfloat F32 noattr + | Mfloat64 => Tfloat F64 noattr + | Many32 => Tvoid + | Many64 => Tvoid + end. + + Definition wf_chunk (ch: memory_chunk): Prop := + match ch with + | Many32 | Many64 => False + | _ => True + end. + + Lemma access_mode_chunk_to_type_wf + ch + (WF: wf_chunk ch) + : + access_mode (chunk_to_type ch) = By_value ch. + Proof. destruct ch; ss. Qed. + + Definition code_mem_delta_kind (d: mem_delta_kind): statement := + match d with + | mem_delta_kind_store (ch, b, ofs, v, cp) => + match Senv.invert_symbol ge b with + | Some id => + Sassign (Ederef (expr_of_addr id ofs) (chunk_to_type ch)) (val_to_expr ge v) + | None => Sskip + end + | _ => Sskip + end. + + (* TODO *) + + | step_assign: forall f a1 a2 k e le m loc ofs bf v2 v m', + eval_lvalue e (comp_of f) le m a1 loc ofs bf -> + eval_expr e (comp_of f) le m a2 v2 -> + sem_cast v2 (typeof a2) (typeof a1) m = Some v -> + assign_loc ge (comp_of f) (typeof a1) m loc ofs bf v m' -> + step (State f (Sassign a1 a2) k e le m) + E0 (State f Sskip k e le m') + + Definition code_bundle_call (tr: trace) (id: ident) (evargs: list eventval) (sg: signature) (omd: option mem_delta): statement := + let tys := from_sig_fun_data sg in + Scall None (Evar id (Tfunction tys.(dargs) tys.(dret) tys.(dcc))) (list_eventval_to_list_expr evargs). + +Variant bundle_event : Type := + Bundle_call : trace -> ident -> list eventval -> signature -> option mem_delta -> bundle_event + | Bundle_return : trace -> eventval -> bundle_event + | Bundle_builtin : trace -> external_function -> list eventval -> mem_delta -> bundle_event. + + (* converting functions *) Definition code_of_external (argsexpr: list expr) (ik: info_kind) := match ik with From 162cacd474f1b47bb055a4c07ed6e739305e285c Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 8 Aug 2023 18:53:14 +0200 Subject: [PATCH 107/174] WIP --- security/Backtranslation.v | 323 ++++++++++++++++++++++++++++++------- 1 file changed, 261 insertions(+), 62 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 189f054fb5..1f23cf74dd 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -411,83 +411,282 @@ Section Backtranslation. End CODEAUX. - Section CONVVAL. - - Context {F: Type}. - Context {V: Type}. - Variable ge: Genv.t F V. - - Definition val_to_expr (v: val) : expr := - match v with - | Vint i => Econst_int i (Tint I32 Signed noattr) - | Vlong i => Econst_long i (Tlong Signed noattr) - | Vfloat f => Econst_float f (Tfloat F64 noattr) - | Vsingle f => Econst_single f (Tfloat F32 noattr) - | Vptr b ofs => let id := senv_invert_symbol_total ge b in ptr_of_id_ofs id ofs - | Vundef => Econst_int Int.zero (Tint I32 Signed noattr) - end. - - End CONVVAL. - + Section CONV. - Section CODE. - (** converting *informative* trace to code **) + (* Context {F: Type}. *) + (* Context {V: Type}. *) + (* Variable ge: Genv.t F V. *) - Context {F: Type}. - Context {V: Type}. - Variable ge: Genv.t F V. + Variable ge: Senv.t. (* Type: Tvoid has size 1, which is what we want *) Definition expr_of_addr (id: ident) (ofs: Z): expr := ptr_of_id_ofs id (Ptrofs.repr ofs). - Definition chunk_to_type (ch: memory_chunk): type := + Definition chunk_to_type (ch: memory_chunk): option type := match ch with - | Mint8signed => Tint I8 Signed noattr - | Mint8unsigned => Tint I8 Unsigned noattr - | Mint16signed =>Tint I16 Signed noattr - | Mint16unsigned =>Tint I16 Unsigned noattr - | Mint32 => Tint I32 Signed noattr - | Mint64 => Tlong Signed noattr - | Mfloat32 => Tfloat F32 noattr - | Mfloat64 => Tfloat F64 noattr - | Many32 => Tvoid - | Many64 => Tvoid + | 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. - Definition wf_chunk (ch: memory_chunk): Prop := - match ch with - | Many32 | Many64 => False - | _ => True + 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 + (* | Vint i => Some (Econst_int i (Tint I32 Signed noattr)) *) + (* | Vlong i => Some (Econst_long i (Tlong Signed noattr)) *) + (* | Vfloat f => Some (Econst_float f (Tfloat F64 noattr)) *) + (* | Vsingle f => Some (Econst_single f (Tfloat F32 noattr)) *) + (* | Vptr b ofs => let id := senv_invert_symbol_total ge b in Some (ptr_of_id_ofs id ofs) *) + | Vundef => None + end + | None => None end. - Lemma access_mode_chunk_to_type_wf - ch - (WF: wf_chunk ch) + End CONV. + + + Section CODE. + (** converting *informative* trace to code **) + + (* TODO list: +cross-call/return -> check current cp - public global blocks are fo +ir: at cross-call/return, invoke a delta +wf_env : if global id -> not exists +change to Mem.storev (for Ptrofs.unsigned ofs) + + *) + + Variable ge: Clight.genv. + + Lemma ptr_of_id_ofs_eval + id ofs e b cp le m + (GE1: wf_env e id) + (GE2: Genv.find_symbol ge id = Some b) : - access_mode (chunk_to_type ch) = By_value ch. - Proof. destruct ch; ss. Qed. + eval_expr ge e cp le m (ptr_of_id_ofs id ofs) (Vptr b ofs). + Proof. + 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. Definition code_mem_delta_kind (d: mem_delta_kind): statement := match d with | mem_delta_kind_store (ch, b, ofs, v, cp) => match Senv.invert_symbol ge b with | Some id => - Sassign (Ederef (expr_of_addr id ofs) (chunk_to_type ch)) (val_to_expr ge v) + match chunk_to_type ch, chunk_val_to_expr ge ch v with + | Some ty, Some ve => Sassign (Ederef (expr_of_addr id ofs) ty) ve + | _, _ => Sskip + end | None => Sskip end | _ => Sskip end. + Lemma type_of_chunk_val_to_expr + ch ty v e + (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. rewrite ptr_of_id_ofs_typeof. + Admitted. + + Lemma sem_cast_chunk_val + m ch ty v e + (CT: chunk_to_type ch = Some ty) + (CVE: chunk_val_to_expr ge ch v = Some e) + : + Cop.sem_cast v (typeof e) ty m = Some v. + Proof. + erewrite type_of_chunk_val_to_expr; eauto. + apply Cop.cast_val_casted. + +encode_val = +fun (chunk : memory_chunk) (v : val) => +match v with +| Vundef => match chunk with + | Many32 => inj_value Q32 v + | Many64 => inj_value Q64 v + | _ => repeat Undef (size_chunk_nat chunk) + end +| Vint n => + match chunk with + | Mint8signed | Mint8unsigned => inj_bytes (encode_int 1 (Int.unsigned n)) + | Mint16signed | Mint16unsigned => inj_bytes (encode_int 2 (Int.unsigned n)) + | Mint32 => inj_bytes (encode_int 4 (Int.unsigned n)) + | Many32 => inj_value Q32 v + | Many64 => inj_value Q64 v + | _ => repeat Undef (size_chunk_nat chunk) + end +| Vlong n => match chunk with + | Mint64 => inj_bytes (encode_int 8 (Int64.unsigned n)) + | Many32 => inj_value Q32 v + | Many64 => inj_value Q64 v + | _ => repeat Undef (size_chunk_nat chunk) + end +| Vfloat n => + match chunk with + | Mfloat64 => inj_bytes (encode_int 8 (Int64.unsigned (Floats.Float.to_bits n))) + | Many32 => inj_value Q32 v + | Many64 => inj_value Q64 v + | _ => repeat Undef (size_chunk_nat chunk) + end +| Vsingle n => + match chunk with + | Mfloat32 => inj_bytes (encode_int 4 (Int.unsigned (Floats.Float32.to_bits n))) + | Many32 => inj_value Q32 v + | Many64 => inj_value Q64 v + | _ => repeat Undef (size_chunk_nat chunk) + end +| Vptr _ _ => + match chunk with + | Mint32 => if Archi.ptr64 then repeat Undef 4 else inj_value Q32 v + | Mint64 => if Archi.ptr64 then inj_value Q64 v else repeat Undef 8 + | Many32 => inj_value Q32 v + | Many64 => inj_value Q64 v + | _ => repeat Undef (size_chunk_nat chunk) + end +end + : memory_chunk -> val -> list memval +Inductive val_casted : val -> type -> Prop := + val_casted_int : forall (sz : intsize) (si : signedness) (attr : attr) (n : int), Cop.cast_int_int sz si n = n -> Cop.val_casted (Vint n) (Tint sz si attr) + | val_casted_float : forall (attr : attr) (n : Floats.float), Cop.val_casted (Vfloat n) (Tfloat F64 attr) + | val_casted_single : forall (attr : attr) (n : Floats.float32), Cop.val_casted (Vsingle n) (Tfloat F32 attr) + | val_casted_long : forall (si : signedness) (attr : attr) (n : int64), Cop.val_casted (Vlong n) (Tlong si attr) + | val_casted_ptr_ptr : forall (b : block) (ofs : ptrofs) (ty : type) (attr : attr), Cop.val_casted (Vptr b ofs) (Tpointer ty attr) + | val_casted_int_ptr : forall (n : int) (ty : type) (attr : attr), Archi.ptr64 = false -> Cop.val_casted (Vint n) (Tpointer ty attr) + | val_casted_ptr_int : forall (b : block) (ofs : ptrofs) (si : signedness) (attr : attr), Archi.ptr64 = false -> Cop.val_casted (Vptr b ofs) (Tint I32 si attr) + | val_casted_long_ptr : forall (n : int64) (ty : type) (attr : attr), Archi.ptr64 = true -> Cop.val_casted (Vlong n) (Tpointer ty attr) + | val_casted_ptr_long : forall (b : block) (ofs : ptrofs) (si : signedness) (attr : attr), Archi.ptr64 = true -> Cop.val_casted (Vptr b ofs) (Tlong si attr) + | val_casted_struct : forall (id : ident) (attr : attr) (b : block) (ofs : ptrofs), Cop.val_casted (Vptr b ofs) (Tstruct id attr) + | val_casted_union : forall (id : ident) (attr : attr) (b : block) (ofs : ptrofs), Cop.val_casted (Vptr b ofs) (Tunion id attr) + | val_casted_void : forall v : val, Cop.val_casted v Tvoid. + +Mem.store_mem_contents: + forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) (m2 : mem), + Mem.store chunk m1 b ofs v cp = Some m2 -> Mem.mem_contents m2 = PMap.set b (Mem.setN (encode_val chunk v) ofs (Mem.mem_contents m1) !! b) (Mem.mem_contents m1) +Mem.valid_access = +fun (m : mem) (chunk : memory_chunk) (b : block) (ofs : Z) (p : permission) (cp : option compartment) => +Mem.range_perm m b ofs (ofs + size_chunk chunk) Cur p /\ Mem.can_access_block m b cp /\ (align_chunk chunk | ofs) + : mem -> memory_chunk -> block -> Z -> permission -> option compartment -> Prop +Mem.store = +fun (chunk : memory_chunk) (m : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) => +match Mem.valid_access_dec m chunk b ofs Writable (Some cp) with +| left x => + Some + {| + Mem.mem_contents := PMap.set b (Mem.setN (encode_val chunk v) ofs (Mem.mem_contents m) !! b) (Mem.mem_contents m); + Mem.mem_access := Mem.mem_access m; + Mem.mem_compartments := Mem.mem_compartments m; + Mem.nextblock := Mem.nextblock m; + Mem.access_max := + (fun (chunk0 : memory_chunk) (m0 : mem) (b0 : block) (ofs0 : Z) (_ : val) (cp0 : compartment) (_ : Mem.valid_access m0 chunk0 b0 ofs0 Writable (Some cp0)) (b1 : positive) (ofs1 : Z) => + Memory.Mem.store_obligation_1 m0 b1 ofs1) chunk m b ofs v cp x; + Mem.nextblock_noaccess := + (fun (chunk0 : memory_chunk) (m0 : mem) (b0 : block) (ofs0 : Z) (_ : val) (cp0 : compartment) (_ : Mem.valid_access m0 chunk0 b0 ofs0 Writable (Some cp0)) (b1 : positive) + (ofs1 : Z) (k : perm_kind) (H0 : ~ Plt b1 (Mem.nextblock m0)) => Memory.Mem.store_obligation_2 m0 b1 ofs1 k H0) chunk m b ofs v cp x; + Mem.contents_default := + (fun (chunk0 : memory_chunk) (m0 : mem) (b0 : block) (ofs0 : Z) (v0 : val) (cp0 : compartment) (_ : Mem.valid_access m0 chunk0 b0 ofs0 Writable (Some cp0)) (b1 : positive) => + Memory.Mem.store_obligation_3 chunk0 m0 b0 ofs0 v0 b1) chunk m b ofs v cp x; + Mem.nextblock_compartments := + (fun (chunk0 : memory_chunk) (m0 : mem) (b0 : block) (ofs0 : Z) (_ : val) (cp0 : compartment) (_ : Mem.valid_access m0 chunk0 b0 ofs0 Writable (Some cp0)) (b1 : positive) => + Memory.Mem.store_obligation_4 m0 b1) chunk m b ofs v cp x + |} +| right _ => None +end + : memory_chunk -> mem -> block -> Z -> val -> compartment -> option mem + + + + unfold chunk_val_to_expr in CVE. rewrite CT in CVE. + destruct ch; ss; clarify. + - unfold chunk_val_to_expr in CVE. ss. des_ifs; ss; simpl_expr. + * admit. + * + + + + (* unfold chunk_to_type in CT. unfold chunk_val_to_expr in CVE. *) + (* unfold Cop.sem_cast. des_ifs. *) + + + (* destruct ch; destruct v; ss; eauto. simpl_expr. *) + + Lemma code_mem_delta_kind_correct + d f k e le m m' + (DEL: code_mem_delta_kind d <> Sskip) + (STORE: mem_delta_apply [d] (Some m) = Some m') + : + (step1 ge (State f (code_mem_delta_kind d) k e le m) E0 (State f Sskip k e le m')). + Proof. + destruct d; ss. des_ifs. clear DEL. ss. eapply step_assign. + - econs. unfold expr_of_addr. eapply ptr_of_id_ofs_eval. admit. eapply Genv.invert_find_symbol; eauto. + - instantiate (1:=v). admit. + - ss. admit. + - simpl_expr. eapply access_mode_chunk_to_type_wf; eauto. + + + simpl_expr. admit. instantiate (1:=b). admit. + + + + (* TODO *) | step_assign: forall f a1 a2 k e le m loc ofs bf v2 v m', eval_lvalue e (comp_of f) le m a1 loc ofs bf -> eval_expr e (comp_of f) le m a2 v2 -> - sem_cast v2 (typeof a2) (typeof a1) m = Some v -> + Cop.sem_cast v2 (typeof a2) (typeof a1) m = Some v -> assign_loc ge (comp_of f) (typeof a1) m loc ofs bf v m' -> step (State f (Sassign a1 a2) k e le m) E0 (State f Sskip k e le m') +Inductive assign_loc (ce : composite_env) (cp : compartment) (ty : type) (m : mem) (b : block) (ofs : ptrofs) : bitfield -> val -> mem -> Prop := + assign_loc_value : forall (v : val) (chunk : memory_chunk) (m' : mem), access_mode ty = By_value chunk -> Mem.storev chunk m (Vptr b ofs) v cp = Some m' -> assign_loc ce cp ty m b ofs Full v m' +Cop.sem_add = +fun (cenv : composite_env) (v1 : val) (t1 : type) (v2 : val) (t2 : type) (m : mem) => +match Cop.classify_add t1 t2 with +| Cop.add_case_pi ty si => Cop.sem_add_ptr_int cenv ty si v1 v2 +| Cop.add_case_pl ty => Cop.sem_add_ptr_long cenv ty v1 v2 +| Cop.add_case_ip si ty => Cop.sem_add_ptr_int cenv ty si v2 v1 +| Cop.add_case_lp ty => Cop.sem_add_ptr_long cenv ty v2 v1 +| Cop.add_default => + Cop.sem_binarith (fun (_ : signedness) (n1 n2 : int) => Some (Vint (Int.add n1 n2))) (fun (_ : signedness) (n1 n2 : int64) => Some (Vlong (Int64.add n1 n2))) + (fun n1 n2 : Floats.float => Some (Vfloat (Floats.Float.add n1 n2))) (fun n1 n2 : Floats.float32 => Some (Vsingle (Floats.Float32.add n1 n2))) v1 t1 v2 t2 m +end + : composite_env -> val -> type -> val -> type -> mem -> option val Definition code_bundle_call (tr: trace) (id: ident) (evargs: list eventval) (sg: signature) (omd: option mem_delta): statement := let tys := from_sig_fun_data sg in @@ -626,23 +825,23 @@ Variant bundle_event : Type := typ_of_type (typ_to_type ty) = ty. Proof. inversion EM; simpl; auto. subst. unfold Tptr. destruct Archi.ptr64; simpl; auto. Qed. - Lemma ptr_of_id_ofs_eval - id ofs e (ge: genv) b cp le m - (GE1: wf_env e id) - (GE2: Genv.find_symbol ge id = Some b) - : - eval_expr ge e cp le m (ptr_of_id_ofs id ofs) (Vptr b ofs). - Proof. - 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 ptr_of_id_ofs_eval *) + (* id ofs e (ge: genv) b cp le m *) + (* (GE1: wf_env e id) *) + (* (GE2: Genv.find_symbol ge id = Some b) *) + (* : *) + (* eval_expr ge e cp le m (ptr_of_id_ofs id ofs) (Vptr b ofs). *) + (* Proof. *) + (* 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 eventval_to_expr_val_eval (ge: genv) en cp temp m ev From 8bebec3ceaed8e8eeecba1488289a1b736c94754 Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 9 Aug 2023 16:03:20 +0200 Subject: [PATCH 108/174] WIP; start changing mem delta store to storev --- security/Backtranslation.v | 355 ++++++++++++++++++++++++------------- security/MemoryDelta.v | 9 +- 2 files changed, 235 insertions(+), 129 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 1f23cf74dd..5814e653b6 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -188,13 +188,14 @@ Section Backtranslation. Section CONV. (** converting event to data **) - Context {F: Type}. - Context {V: Type}. - Variable ge: Genv.t F V. + Variable ge: Senv.t. + + Definition not_in_env (e: env) id := e ! id = None. - Definition wf_env (e: env) id := e ! id = None. + Definition wf_env (e: env) := + forall id, if (Senv.public_symbol ge id) then not_in_env e id else True. - Definition eventval_to_val (ge: Senv.t) (v: eventval): val := + Definition eventval_to_val (v: eventval): val := match v with | EVint i => Vint i | EVlong i => Vlong i @@ -206,8 +207,8 @@ Section Backtranslation. end end. - Definition list_eventval_to_list_val ge (vs: list eventval): list val := - List.map (eventval_to_val ge) vs. + 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 @@ -253,30 +254,6 @@ Section Backtranslation. | EVptr_global id ofs => ptr_of_id_ofs id ofs end. - Definition wf_eventval_env (e: env) (v: eventval): Prop := - match v with - | EVptr_global id _ => wf_env e id - | _ => True - end. - - Definition wf_eventval_pub (v: eventval): Prop := - match v with - | EVptr_global id _ => (Senv.public_symbol ge id = true) - | _ => True - end. - - Definition wf_eventval_ge (v: eventval): Prop := - match v with - | EVptr_global id _ => (exists b, Genv.find_symbol ge id = Some b) - | _ => True - end. - - Lemma wf_eventval_pub_ge - v - : - wf_eventval_pub v -> wf_eventval_ge v. - Proof. intros H. destruct v; simpl in *; auto. apply Genv.public_symbol_exists in H; auto. Qed. - Definition list_eventval_to_list_expr (vs: list eventval): list expr := List.map eventval_to_expr vs. @@ -286,6 +263,30 @@ Section Backtranslation. typeof (eventval_to_expr v) = eventval_to_type v. Proof. destruct v; simpl; auto. apply ptr_of_id_ofs_typeof. Qed. + (* Definition wf_eventval_env (e: env) (v: eventval): Prop := *) + (* match v with *) + (* | EVptr_global id _ => wf_env e id *) + (* | _ => True *) + (* end. *) + + Definition wf_eventval_pub (v: eventval): Prop := + match v with + | EVptr_global id _ => (Senv.public_symbol ge id = true) + | _ => True + end. + + (* Definition wf_eventval_ge (v: eventval): Prop := *) + (* match v with *) + (* | EVptr_global id _ => (exists b, Genv.find_symbol ge id = Some b) *) + (* | _ => True *) + (* end. *) + + (* Lemma wf_eventval_pub_ge *) + (* v *) + (* : *) + (* wf_eventval_pub v -> wf_eventval_ge v. *) + (* Proof. intros H. destruct v; simpl in *; auto. apply Genv.public_symbol_exists in H; auto. Qed. *) + End CONV. @@ -411,6 +412,56 @@ Section Backtranslation. End CODEAUX. + Section WFSTORE. + + 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_chunk_val ch v := is_true (wf_chunk_val_b ch v). + + Definition wf_mem_delta_store_b (ge: Senv.t) (cp0: compartment) (d: mem_delta_store) := + let '(ch, b, _, v, cp) := d in + 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. + + Definition wf_mem_delta_kind_b (ge: Senv.t) cp0 (d: mem_delta_kind) := + match d with | mem_delta_kind_store dd => wf_mem_delta_store_b ge cp0 dd | _ => false end. + + End WFSTORE. + + Section CONV. (* Context {F: Type}. *) @@ -476,7 +527,6 @@ Section Backtranslation. (* TODO list: cross-call/return -> check current cp - public global blocks are fo ir: at cross-call/return, invoke a delta -wf_env : if global id -> not exists change to Mem.storev (for Ptrofs.unsigned ofs) *) @@ -485,11 +535,13 @@ change to Mem.storev (for Ptrofs.unsigned ofs) Lemma ptr_of_id_ofs_eval id ofs e b cp le m - (GE1: wf_env e id) - (GE2: Genv.find_symbol ge id = Some b) + (GE1: wf_env ge e) + (GE2: Senv.public_symbol ge id) + (GE3: 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. @@ -501,100 +553,170 @@ change to Mem.storev (for Ptrofs.unsigned ofs) erewrite Ptrofs.agree32_of_ints_eq; auto. apply Ptrofs.agree32_to_int; auto. Qed. + Definition code_mem_delta_store (d: mem_delta_store): statement := + let '(ch, b, ofs, v, cp) := d in + if (wf_chunk_val_b ch v) then + 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 => Sassign (Ederef (expr_of_addr id ofs) ty) ve + | _, _ => Sskip + end + | None => Sskip + end + else Sskip. + Definition code_mem_delta_kind (d: mem_delta_kind): statement := match d with - | mem_delta_kind_store (ch, b, ofs, v, cp) => - 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 => Sassign (Ederef (expr_of_addr id ofs) ty) ve - | _, _ => Sskip - end - | None => Sskip - end + | mem_delta_kind_store dd => code_mem_delta_store dd | _ => Sskip end. Lemma type_of_chunk_val_to_expr ch ty v e + (WF: wf_chunk_val 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. rewrite ptr_of_id_ofs_typeof. - Admitted. + 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 m ch ty v e + (WF: wf_chunk_val 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. - -encode_val = -fun (chunk : memory_chunk) (v : val) => -match v with -| Vundef => match chunk with - | Many32 => inj_value Q32 v - | Many64 => inj_value Q64 v - | _ => repeat Undef (size_chunk_nat chunk) - end -| Vint n => - match chunk with - | Mint8signed | Mint8unsigned => inj_bytes (encode_int 1 (Int.unsigned n)) - | Mint16signed | Mint16unsigned => inj_bytes (encode_int 2 (Int.unsigned n)) - | Mint32 => inj_bytes (encode_int 4 (Int.unsigned n)) - | Many32 => inj_value Q32 v - | Many64 => inj_value Q64 v - | _ => repeat Undef (size_chunk_nat chunk) - end -| Vlong n => match chunk with - | Mint64 => inj_bytes (encode_int 8 (Int64.unsigned n)) - | Many32 => inj_value Q32 v - | Many64 => inj_value Q64 v - | _ => repeat Undef (size_chunk_nat chunk) - end -| Vfloat n => - match chunk with - | Mfloat64 => inj_bytes (encode_int 8 (Int64.unsigned (Floats.Float.to_bits n))) - | Many32 => inj_value Q32 v - | Many64 => inj_value Q64 v - | _ => repeat Undef (size_chunk_nat chunk) - end -| Vsingle n => - match chunk with - | Mfloat32 => inj_bytes (encode_int 4 (Int.unsigned (Floats.Float32.to_bits n))) - | Many32 => inj_value Q32 v - | Many64 => inj_value Q64 v - | _ => repeat Undef (size_chunk_nat chunk) - end -| Vptr _ _ => - match chunk with - | Mint32 => if Archi.ptr64 then repeat Undef 4 else inj_value Q32 v - | Mint64 => if Archi.ptr64 then inj_value Q64 v else repeat Undef 8 - | Many32 => inj_value Q32 v - | Many64 => inj_value Q64 v - | _ => repeat Undef (size_chunk_nat chunk) - end -end - : memory_chunk -> val -> list memval -Inductive val_casted : val -> type -> Prop := - val_casted_int : forall (sz : intsize) (si : signedness) (attr : attr) (n : int), Cop.cast_int_int sz si n = n -> Cop.val_casted (Vint n) (Tint sz si attr) - | val_casted_float : forall (attr : attr) (n : Floats.float), Cop.val_casted (Vfloat n) (Tfloat F64 attr) - | val_casted_single : forall (attr : attr) (n : Floats.float32), Cop.val_casted (Vsingle n) (Tfloat F32 attr) - | val_casted_long : forall (si : signedness) (attr : attr) (n : int64), Cop.val_casted (Vlong n) (Tlong si attr) - | val_casted_ptr_ptr : forall (b : block) (ofs : ptrofs) (ty : type) (attr : attr), Cop.val_casted (Vptr b ofs) (Tpointer ty attr) - | val_casted_int_ptr : forall (n : int) (ty : type) (attr : attr), Archi.ptr64 = false -> Cop.val_casted (Vint n) (Tpointer ty attr) - | val_casted_ptr_int : forall (b : block) (ofs : ptrofs) (si : signedness) (attr : attr), Archi.ptr64 = false -> Cop.val_casted (Vptr b ofs) (Tint I32 si attr) - | val_casted_long_ptr : forall (n : int64) (ty : type) (attr : attr), Archi.ptr64 = true -> Cop.val_casted (Vlong n) (Tpointer ty attr) - | val_casted_ptr_long : forall (b : block) (ofs : ptrofs) (si : signedness) (attr : attr), Archi.ptr64 = true -> Cop.val_casted (Vptr b ofs) (Tlong si attr) - | val_casted_struct : forall (id : ident) (attr : attr) (b : block) (ofs : ptrofs), Cop.val_casted (Vptr b ofs) (Tstruct id attr) - | val_casted_union : forall (id : ident) (attr : attr) (b : block) (ofs : ptrofs), Cop.val_casted (Vptr b ofs) (Tunion id attr) - | val_casted_void : forall v : val, Cop.val_casted v Tvoid. + erewrite type_of_chunk_val_to_expr; eauto. apply Cop.cast_val_casted. clear - WF CT NINT. + unfold wf_chunk_val, 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 + ch v exp e cp le m + (EXP: chunk_val_to_expr ge ch v = Some exp) + (WF: wf_chunk_val 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 + 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_store_correct + f k e le m m' + d + (WFE: wf_env ge e) + (STORE: mem_delta_apply_store (Some m) d = Some m') + (WF: wf_mem_delta_store_b ge (comp_of f) d) + : + (step1 ge (State f (code_mem_delta_store d) k e le m) E0 (State f Sskip k e le m')). + Proof. + unfold wf_mem_delta_store_b in WF. des_ifs. rename m0 into ch, z into ofs. ss. + (* specialize (WFE i). rewrite H0 in WFE. *) + 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 i0). eapply chunk_val_to_expr_eval; eauto. + - instantiate (1:=cast_chunk_int ch i0). 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. + (*** TODO *) + rewrite <- STORE. destruct ch; ss. + + rewrite Mem.store_int8_sign_ext. admit. + + rewrite Mem.store_int8_zero_ext. admit. + + rewrite Mem.store_int16_sign_ext. admit. + + rewrite Mem.store_int16_zero_ext. admit. + + admit. + } + { eapply step_assign. + - econs. unfold expr_of_addr. eapply ptr_of_id_ofs_eval. admit. 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. admit. + } + Qed. + + Lemma code_mem_delta_kind_correct + d f k e le m m' + (WFE: wf_env ge e) + (DEL: code_mem_delta_kind d <> Sskip) + (STORE: mem_delta_apply [d] (Some m) = Some m') + (WF: mem_delta_kind_wf d) + : + (step1 ge (State f (code_mem_delta_kind d) k e le m) E0 (State f Sskip k e le m')). + Proof. + destruct d; ss. des_ifs. clear DEL. ss. 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. admit. eapply Genv.invert_find_symbol; eauto. + - instantiate (1:=Vint i0). eapply chunk_val_to_expr_eval; eauto. + - ss. instantiate (1:=cast_chunk_int m0 i0). rename m0 into ch. erewrite type_of_chunk_val_to_expr; eauto. + unfold chunk_to_type in Heq0. destruct ch; ss; inv Heq0. + + 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. destruct m0; ss. + + rewrite Mem.store_int8_sign_ext. admit. + + rewrite Mem.store_int8_zero_ext. admit. + + rewrite Mem.store_int16_sign_ext. admit. + + rewrite Mem.store_int16_zero_ext. admit. + + admit. + } + { eapply step_assign. + - econs. unfold expr_of_addr. eapply ptr_of_id_ofs_eval. admit. 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. admit. + } + Qed. + + + Mem.store_mem_contents: forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) (m2 : mem), @@ -646,23 +768,6 @@ end (* destruct ch; destruct v; ss; eauto. simpl_expr. *) - Lemma code_mem_delta_kind_correct - d f k e le m m' - (DEL: code_mem_delta_kind d <> Sskip) - (STORE: mem_delta_apply [d] (Some m) = Some m') - : - (step1 ge (State f (code_mem_delta_kind d) k e le m) E0 (State f Sskip k e le m')). - Proof. - destruct d; ss. des_ifs. clear DEL. ss. eapply step_assign. - - econs. unfold expr_of_addr. eapply ptr_of_id_ofs_eval. admit. eapply Genv.invert_find_symbol; eauto. - - instantiate (1:=v). admit. - - ss. admit. - - simpl_expr. eapply access_mode_chunk_to_type_wf; eauto. - - - simpl_expr. admit. instantiate (1:=b). admit. - + - (* TODO *) diff --git a/security/MemoryDelta.v b/security/MemoryDelta.v index ba43b302fe..26b253a023 100644 --- a/security/MemoryDelta.v +++ b/security/MemoryDelta.v @@ -158,7 +158,8 @@ Section MEMDELTA. (** Memory delta data and apply *) (* Data to get injection by invoking correct Mem.store: inj + (apply delta) = inj *) - Definition mem_delta_store := (memory_chunk * block * Z * val * compartment)%type. + Definition mem_delta_store := (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. @@ -174,9 +175,9 @@ Section MEMDELTA. Definition mem_delta := list mem_delta_kind. Definition mem_delta_apply_store (om: option mem) (d: mem_delta_store): option mem := - let '(ch, b, ofs, v, cp) := d in + let '(ch, ptr, v, cp) := d in match om with - | Some m => Mem.store ch m b ofs v cp + | Some m => Mem.storev ch m ptr v cp | None => None end. @@ -184,7 +185,7 @@ Section MEMDELTA. d : mem_delta_apply_store None d = None. - Proof. unfold mem_delta_apply_store. destruct d as [[[[d0 d1] d2] d3] d4]. auto. Qed. + Proof. unfold mem_delta_apply_store. destruct d as [[[d0 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 From fd811169be12c6b0f3064cacc4042965460b1dad Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 9 Aug 2023 18:27:36 +0200 Subject: [PATCH 109/174] WIP; major change in mem_delta --- security/Backtranslation.v | 50 ----- security/MemoryDelta.v | 423 +++++++++++++++++++++++++++---------- 2 files changed, 307 insertions(+), 166 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 5814e653b6..1c2daeb384 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -412,56 +412,6 @@ Section Backtranslation. End CODEAUX. - Section WFSTORE. - - 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_chunk_val ch v := is_true (wf_chunk_val_b ch v). - - Definition wf_mem_delta_store_b (ge: Senv.t) (cp0: compartment) (d: mem_delta_store) := - let '(ch, b, _, v, cp) := d in - 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. - - Definition wf_mem_delta_kind_b (ge: Senv.t) cp0 (d: mem_delta_kind) := - match d with | mem_delta_kind_store dd => wf_mem_delta_store_b ge cp0 dd | _ => false end. - - End WFSTORE. - - Section CONV. (* Context {F: Type}. *) diff --git a/security/MemoryDelta.v b/security/MemoryDelta.v index 26b253a023..1e87e80aa4 100644 --- a/security/MemoryDelta.v +++ b/security/MemoryDelta.v @@ -2,7 +2,7 @@ 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. @@ -158,34 +158,48 @@ Section MEMDELTA. (** Memory delta data and apply *) (* Data to get injection by invoking correct Mem.store: inj + (apply delta) = inj *) - Definition mem_delta_store := (memory_chunk * val * val * compartment)%type. - (* Definition mem_delta_store := (memory_chunk * block * Z * val * compartment)%type. *) + 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) . - (* old to new *) + (* order: old to new *) Definition mem_delta := list mem_delta_kind. - Definition mem_delta_apply_store (om: option mem) (d: mem_delta_store): option mem := + 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 d2] d3] d4]. auto. Qed. + 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 @@ -226,22 +240,24 @@ Section MEMDELTA. 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 => - match data with - | 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 - ) d om0. + 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) @@ -265,7 +281,8 @@ Section MEMDELTA. mem_delta_apply d None = None. Proof. induction d; auto. rewrite mem_delta_apply_cons. - destruct a; [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. + 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 @@ -275,84 +292,131 @@ Section MEMDELTA. 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 *) + + 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 mem_delta_apply_inj (j: meminj) (d: mem_delta) (om0: option mem) : option mem := - fold_left (fun om data => - match data with - | mem_delta_kind_store (ch, b, ofs, v, cp) => - match j b with - | Some (b', ofsd) => - mem_delta_apply_store om (ch, b', (ofs + ofsd)%Z, v, cp) - | None => om - end - | _ => om - end) d (om0). + Definition get_wf_mem_delta (ge: Senv.t) cp0 (d: mem_delta): mem_delta := + filter (wf_mem_delta_kind_b ge cp0) d. - Lemma mem_delta_apply_inj_cons - j d m0 k + Lemma get_wf_mem_delta_cons + ge cp0 d k : - mem_delta_apply_inj j (k :: d) m0 = - match k with - | mem_delta_kind_store (ch, b, ofs, v, cp) => - match j b with - | Some (b', ofsd) => - mem_delta_apply_inj j d (mem_delta_apply_store m0 (ch, b', (ofs + ofsd)%Z, v, cp)) - | None => mem_delta_apply_inj j d m0 - end - | mem_delta_kind_bytes dd - | mem_delta_kind_alloc dd - | mem_delta_kind_free dd => mem_delta_apply_inj j d m0 - end. - Proof. simpl. destruct k; auto. destruct d0 as [[[[a0 a1] a2] a3] a4]. destruct (j a1); auto. destruct p. auto. Qed. + 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 mem_delta_apply_inj_app - j d0 d1 m0 + Lemma get_wf_mem_delta_app + ge cp0 d0 d1 : - mem_delta_apply_inj j (d0 ++ d1) m0 = mem_delta_apply_inj j d1 (mem_delta_apply_inj j d0 m0). - Proof. - revert j d1 m0. induction d0; intros. - { simpl. auto. } - rewrite <- app_comm_cons. rewrite ! mem_delta_apply_inj_cons. destruct a; auto. - { destruct d as [[[[a0 a1] a2] a3] a4]. destruct (j a1); auto. destruct p; auto. } - Qed. + 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. - Lemma mem_delta_apply_inj_none - j d + + 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_inj j d None = None. - Proof. - induction d; auto. rewrite mem_delta_apply_inj_cons. - destruct a. destruct d0 as [[[[a0 a1] a2] a3] a4]. destruct (j a1). destruct p. rewrite mem_delta_apply_store_none. all: rewrite IHd; auto. - Qed. + 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_inj_some - j d om m' - (APPD: mem_delta_apply_inj j d om = Some m') + Lemma mem_delta_apply_wf_app + ge cp0 d0 d1 m0 : - exists m, om = Some m. - Proof. destruct om; eauto. rewrite mem_delta_apply_inj_none in APPD. inv APPD. Qed. + 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. - (** Delta and injection relations *) + 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. - Definition mem_delta_kind_inj_wf (j: meminj): mem_delta_kind -> Prop := - fun data => - match data with - | mem_delta_kind_bytes (b, ofs, mvs, cp) => (j b) = None - | mem_delta_kind_free (b, lo, hi, cp) => (j b) = None - | _ => True - end. +End WFDELTA. - Definition mem_delta_inj_wf (j: meminj): mem_delta -> Prop := - fun d => Forall (fun data => mem_delta_kind_inj_wf j data) d. - Lemma mem_delta_inj_wf_rev - j d - : - mem_delta_inj_wf j d <-> mem_delta_inj_wf j (rev d). - Proof. - unfold mem_delta_inj_wf. split; intros. apply Forall_rev; auto. rewrite <- rev_involutive. apply Forall_rev. auto. - Qed. +Section PROPS. + (** Props for proofs *) + + (* Definition mem_delta_kind_inj_wf (j: meminj): mem_delta_kind -> Prop := *) + (* fun data => *) + (* match data with *) + (* | 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 (j: meminj): mem_delta -> Prop := *) + (* fun d => Forall (fun data => mem_delta_kind_inj_wf j data) d. *) + + (* Lemma mem_delta_inj_wf_rev *) + (* j d *) + (* : *) + (* mem_delta_inj_wf j d <-> mem_delta_inj_wf j (rev d). *) + (* Proof. *) + (* unfold mem_delta_inj_wf. split; intros. apply Forall_rev; auto. rewrite <- rev_involutive. apply Forall_rev. auto. *) + (* Qed. *) 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. @@ -362,9 +426,25 @@ Section MEMDELTA. (** Delta and location relations *) + 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'). + 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' @@ -372,7 +452,7 @@ Section MEMDELTA. : Mem.unchanged_on (fun b ofs => mem_delta_unchanged_store d b ofs) m m'. Proof. - destruct d as ((((ch & b) & ofs) & v) & cp). simpl in *. + destruct d as ((((ch & b) & ofs) & v) & cp). ss. eapply Mem.store_unchanged_on. eauto. intros. intros CONTRA. specialize (CONTRA eq_refl). lia. Qed. @@ -420,6 +500,7 @@ Section MEMDELTA. 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 @@ -438,6 +519,13 @@ Section MEMDELTA. 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. @@ -468,31 +556,38 @@ Section MEMDELTA. } Qed. - Lemma mem_delta_inj_unchanged_on - j d m m' - (STRICT: meminj_strict j) - (APPD: mem_delta_apply_inj j d (Some m) = Some m') - : - Mem.unchanged_on (fun b ofs => (forall b0 ofsd, j b0 <> Some (b, ofsd)) \/ (exists b0 ofsd, j b0 = Some (b, ofsd) /\ mem_delta_unchanged d b0 (ofs - ofsd))) 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_inj_cons in APPD. destruct a. - - destruct d0 as [[[[ch b] ofs] v] cp]. destruct (j b) as [[b' ofs'] |] eqn:JB. - + exploit mem_delta_apply_inj_some. eauto. intros (mi & MEM). rewrite MEM in APPD. - specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. - 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H; eauto. destruct H1 as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. right. eauto. } - { simpl in *. eapply Mem.store_unchanged_on. eauto. intros. intros [CC | CC]. - - specialize (CC b ofs'). congruence. - - destruct CC as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. simpl in H2. destruct (Pos.eqb_spec b b1). - + subst b1. rewrite JB in JB1. inv JB1. specialize (H2 eq_refl). lia. - + specialize (STRICT _ _ _ _ _ JB JB1). subst b1. lia. - } - + specialize (IHd _ _ APPD). eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H; eauto. destruct H1 as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. right. eauto. - - specialize (IHd _ _ APPD). eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H; eauto. destruct H1 as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. right. eauto. - - specialize (IHd _ _ APPD). eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H; eauto. destruct H1 as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. right. eauto. - - specialize (IHd _ _ APPD). eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H; eauto. destruct H1 as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. right. eauto. - 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 mem_delta_inj_unchanged_on *) + (* j d m m' *) + (* (STRICT: meminj_strict j) *) + (* (APPD: mem_delta_apply_inj j d (Some m) = Some m') *) + (* : *) + (* Mem.unchanged_on (fun b ofs => (forall b0 ofsd, j b0 <> Some (b, ofsd)) \/ (exists b0 ofsd, j b0 = Some (b, ofsd) /\ mem_delta_unchanged d b0 (ofs - ofsd))) 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_inj_cons in APPD. destruct a. *) + (* - destruct d0 as [[[[ch b] ofs] v] cp]. destruct (j b) as [[b' ofs'] |] eqn:JB. *) + (* + exploit mem_delta_apply_inj_some. eauto. intros (mi & MEM). rewrite MEM in APPD. *) + (* specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. *) + (* 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H; eauto. destruct H1 as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. right. eauto. } *) + (* { simpl in *. eapply Mem.store_unchanged_on. eauto. intros. intros [CC | CC]. *) + (* - specialize (CC b ofs'). congruence. *) + (* - destruct CC as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. simpl in H2. destruct (Pos.eqb_spec b b1). *) + (* + subst b1. rewrite JB in JB1. inv JB1. specialize (H2 eq_refl). lia. *) + (* + specialize (STRICT _ _ _ _ _ JB JB1). subst b1. lia. *) + (* } *) + (* + specialize (IHd _ _ APPD). eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H; eauto. destruct H1 as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. right. eauto. *) + (* - specialize (IHd _ _ APPD). eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H; eauto. destruct H1 as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. right. eauto. *) + (* - specialize (IHd _ _ APPD). eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H; eauto. destruct H1 as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. right. eauto. *) + (* - specialize (IHd _ _ APPD). eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H; eauto. destruct H1 as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. right. eauto. *) + (* Qed. *) Lemma get_from_setN_same_upto_ofs @@ -534,6 +629,28 @@ Section MEMDELTA. 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)). @@ -592,6 +709,7 @@ Section MEMDELTA. 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 @@ -603,6 +721,12 @@ Section MEMDELTA. (** 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 : @@ -631,7 +755,7 @@ Section MEMDELTA. 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_store. apply mem_delta_cases_bytes. apply mem_delta_cases_alloc. apply mem_delta_cases_free. Qed. + 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 @@ -647,18 +771,21 @@ Section MEMDELTA. - right. constructor 1; auto. Qed. - Lemma mem_delta_changed_only_by_store - j d b ofs - (STRICT: meminj_strict j) - b' ofsd - (INJ: j b = Some (b', ofsd)) - (WF: mem_delta_inj_wf j d) +End PROPS. + +Section PROOFS. + + Lemma mem_delta_changed_only_by_storev + ge cp d b ofs + (* (STRICT: meminj_strict j) *) + (* (INJ: j b = Some (b', ofsd)) *) + (WF: mem_inj_wf (meminj_public ge) d) (CHG: mem_delta_changed d b ofs) m1 m1' m2 m2' (PERM1: Mem.perm m1 b ofs Cur Readable) - (PERM2: Mem.perm m2 b' (ofs + ofsd) Cur Readable) + (PERM2: Mem.perm m2 b ofs Cur Readable) (APPD1: mem_delta_apply d (Some m1) = Some m1') - (APPD2: mem_delta_apply_inj j d (Some m2) = Some m2') + (APPD2: mem_delta_apply_wf ge cp d (Some m2) = Some m2') : ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get (ofs + ofsd) (Mem.mem_contents m2') !! b'. Proof. @@ -711,6 +838,70 @@ Section MEMDELTA. } Qed. + (* Lemma mem_delta_changed_only_by_store *) + (* j d b ofs *) + (* (STRICT: meminj_strict j) *) + (* b' ofsd *) + (* (INJ: j b = Some (b', ofsd)) *) + (* (WF: mem_delta_inj_wf j d) *) + (* (CHG: mem_delta_changed d b ofs) *) + (* m1 m1' m2 m2' *) + (* (PERM1: Mem.perm m1 b ofs Cur Readable) *) + (* (PERM2: Mem.perm m2 b' (ofs + ofsd) Cur Readable) *) + (* (APPD1: mem_delta_apply d (Some m1) = Some m1') *) + (* (APPD2: mem_delta_apply_inj j d (Some m2) = Some m2') *) + (* : *) + (* ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get (ofs + ofsd) (Mem.mem_contents m2') !! b'. *) + (* Proof. *) + (* revert WF CHG m1 m1' m2 m2' PERM1 PERM2 APPD1 APPD2. induction d; intros. *) + (* { inv CHG. } *) + (* rewrite mem_delta_apply_cons in APPD1. rewrite mem_delta_apply_inj_cons in APPD2. inv WF. rename H1 into WF1, H2 into WF2. inv CHG. *) + (* 2:{ specialize (IHd WF2 H0). destruct a. *) + (* - destruct d0 as [[[[ch0 b0 ]ofs0] v0] cp0]. destruct (j b0) as [[b0' ofs0'] |] eqn:JB. *) + (* + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. *) + (* exploit mem_delta_apply_inj_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. *) + (* simpl in *. eapply IHd. 3,4: eauto. 1,2: eapply Mem.perm_store_1; eauto. *) + (* + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. simpl in *. eapply IHd. 3,4: eauto. all: auto. 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. 3,4: eauto. all: auto. *) + (* 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. 3,4: eauto. all: auto. *) + (* destruct (Mem.alloc m1 x y z) eqn:ALLOC. simpl in MEM1. 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. 3,4: eauto. all: auto. *) + (* eapply Mem.perm_free_1; eauto. left. intros CC. subst. congruence. *) + (* } *) + (* rename H0 into CHG. destruct (mem_delta_unchanged_or_changed d b ofs). *) + (* 2:{ specialize (IHd WF2 H). destruct a. *) + (* - destruct d0 as [[[[ch0 b0 ]ofs0] v0] cp0]. destruct (j b0) as [[b0' ofs0'] |] eqn:JB. *) + (* + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. *) + (* exploit mem_delta_apply_inj_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. *) + (* simpl in *. eapply IHd. 3,4: eauto. 1,2: eapply Mem.perm_store_1; eauto. *) + (* + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. simpl in *. eapply IHd. 3,4: eauto. all: auto. 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. 3,4: eauto. all: auto. *) + (* 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. 3,4: eauto. all: auto. *) + (* destruct (Mem.alloc m1 x y z) eqn:ALLOC. simpl in MEM1. 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. 3,4: eauto. all: auto. *) + (* eapply Mem.perm_free_1; eauto. left. intros CC. subst. congruence. *) + (* } *) + (* rename H into UNCHG. clear IHd. *) + (* { destruct a. *) + (* - destruct d0 as [[[[ch0 b0] ofs0] v0] cp0]. destruct CHG as [CHG0 CHG1]. subst b0. rewrite INJ in APPD2. *) + (* exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. exploit mem_delta_apply_inj_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. *) + (* simpl in *. *) + (* eapply mem_delta_unchanged_on in APPD1. exploit (Mem.unchanged_on_contents _ _ _ APPD1 b ofs); auto. *) + (* { eapply Mem.perm_store_1; eauto. } *) + (* intros. rewrite H; clear H. *) + (* eapply mem_delta_inj_unchanged_on in APPD2; auto. exploit (Mem.unchanged_on_contents _ _ _ APPD2 b' (ofs + ofsd)); auto. *) + (* { right. exists b, ofsd. split; auto. replace (ofs + ofsd - ofsd) with ofs by lia. auto. } *) + (* { eapply Mem.perm_store_1; eauto. } *) + (* intros. rewrite H; clear H. *) + (* eapply mem_store_same_upto_ofs; eauto. *) + (* - destruct d0 as [[[w x] y] z]. simpl in *. destruct CHG as [CHG0 CHG1]. subst w. rewrite WF1 in INJ. inv INJ. *) + (* - destruct d0 as [[x y] z]. simpl in *. inv CHG. *) + (* - destruct d0 as [[[w x] y] z]. simpl in *. inv CHG. rewrite WF1 in INJ. inv INJ. *) + (* } *) + (* Qed. *) + Lemma mem_delta_apply_preserves_winject (j: meminj) m0 m0' (WINJ0: winject j m0 m0') From f96b1fc7105c52a41a87ca4e0bb518efe3aaff85 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 10 Aug 2023 18:15:23 +0200 Subject: [PATCH 110/174] WIP-new mem delta --- riscV/Asm.v | 18 +- security/MemoryDelta.v | 429 +++++++++++++++++++++++++---------------- 2 files changed, 272 insertions(+), 175 deletions(-) diff --git a/riscV/Asm.v b/riscV/Asm.v index b05efd56ad..7916ac11f3 100644 --- a/riscV/Asm.v +++ b/riscV/Asm.v @@ -1399,10 +1399,12 @@ 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'). -(* 3 fixes: -check sig when call CALLSIG, public & -first order args when undefined external call ECC & -builtin result register is only from mreg *) +(* 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, @@ -1436,8 +1438,11 @@ Inductive step_fix: state -> trace -> state -> Prop := 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.InternalCall -> + 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, @@ -1473,6 +1478,9 @@ Inductive step_fix: state -> trace -> state -> Prop := (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, diff --git a/security/MemoryDelta.v b/security/MemoryDelta.v index 1e87e80aa4..abe009ce17 100644 --- a/security/MemoryDelta.v +++ b/security/MemoryDelta.v @@ -396,36 +396,11 @@ End WFDELTA. Section PROPS. - (** Props for proofs *) - - (* Definition mem_delta_kind_inj_wf (j: meminj): mem_delta_kind -> Prop := *) - (* fun data => *) - (* match data with *) - (* | 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 (j: meminj): mem_delta -> Prop := *) - (* fun d => Forall (fun data => mem_delta_kind_inj_wf j data) d. *) - - (* Lemma mem_delta_inj_wf_rev *) - (* j d *) - (* : *) - (* mem_delta_inj_wf j d <-> mem_delta_inj_wf j (rev d). *) - (* Proof. *) - (* unfold mem_delta_inj_wf. split; intros. apply Forall_rev; auto. rewrite <- rev_involutive. apply Forall_rev. auto. *) - (* Qed. *) - - 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. - (** 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 @@ -774,162 +749,274 @@ Section PROPS. 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 - (* (STRICT: meminj_strict j) *) - (* (INJ: j b = Some (b', ofsd)) *) - (WF: mem_inj_wf (meminj_public ge) d) + (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' - (PERM1: Mem.perm m1 b ofs Cur Readable) - (PERM2: Mem.perm m2 b ofs Cur Readable) (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 + ofsd) (Mem.mem_contents m2') !! b'. + ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get ofs (Mem.mem_contents m2') !! b. Proof. - revert WF CHG m1 m1' m2 m2' PERM1 PERM2 APPD1 APPD2. induction d; intros. + 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_inj_cons in APPD2. inv WF. rename H1 into WF1, H2 into WF2. 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 b0 ]ofs0] v0] cp0]. destruct (j b0) as [[b0' ofs0'] |] eqn:JB. + - 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_inj_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. - simpl in *. eapply IHd. 3,4: eauto. 1,2: eapply Mem.perm_store_1; eauto. - + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. simpl in *. eapply IHd. 3,4: eauto. all: auto. 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. 3,4: eauto. all: auto. + 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. 3,4: eauto. all: auto. - destruct (Mem.alloc m1 x y z) eqn:ALLOC. simpl in MEM1. 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. 3,4: eauto. all: auto. - eapply Mem.perm_free_1; eauto. left. intros CC. subst. congruence. + - 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 b0 ]ofs0] v0] cp0]. destruct (j b0) as [[b0' ofs0'] |] eqn:JB. + - 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_inj_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. - simpl in *. eapply IHd. 3,4: eauto. 1,2: eapply Mem.perm_store_1; eauto. - + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. simpl in *. eapply IHd. 3,4: eauto. all: auto. 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. 3,4: eauto. all: auto. + 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. 3,4: eauto. all: auto. - destruct (Mem.alloc m1 x y z) eqn:ALLOC. simpl in MEM1. 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. 3,4: eauto. all: auto. - eapply Mem.perm_free_1; eauto. left. intros CC. subst. congruence. + - 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. - - destruct d0 as [[[[ch0 b0] ofs0] v0] cp0]. destruct CHG as [CHG0 CHG1]. subst b0. rewrite INJ in APPD2. - exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. exploit mem_delta_apply_inj_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. - simpl in *. - eapply mem_delta_unchanged_on in APPD1. exploit (Mem.unchanged_on_contents _ _ _ APPD1 b ofs); auto. - { eapply Mem.perm_store_1; eauto. } - intros. rewrite H; clear H. - eapply mem_delta_inj_unchanged_on in APPD2; auto. exploit (Mem.unchanged_on_contents _ _ _ APPD2 b' (ofs + ofsd)); auto. - { right. exists b, ofsd. split; auto. replace (ofs + ofsd - ofsd) with ofs by lia. auto. } - { eapply Mem.perm_store_1; eauto. } - intros. rewrite H; clear H. - eapply mem_store_same_upto_ofs; eauto. - - destruct d0 as [[[w x] y] z]. simpl in *. destruct CHG as [CHG0 CHG1]. subst w. rewrite WF1 in INJ. inv INJ. - - destruct d0 as [[x y] z]. simpl in *. inv CHG. - - destruct d0 as [[[w x] y] z]. simpl in *. inv CHG. rewrite WF1 in INJ. inv INJ. + 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 mem_delta_changed_only_by_store *) - (* j d b ofs *) - (* (STRICT: meminj_strict j) *) - (* b' ofsd *) - (* (INJ: j b = Some (b', ofsd)) *) - (* (WF: mem_delta_inj_wf j d) *) - (* (CHG: mem_delta_changed d b ofs) *) - (* m1 m1' m2 m2' *) - (* (PERM1: Mem.perm m1 b ofs Cur Readable) *) - (* (PERM2: Mem.perm m2 b' (ofs + ofsd) Cur Readable) *) - (* (APPD1: mem_delta_apply d (Some m1) = Some m1') *) - (* (APPD2: mem_delta_apply_inj j d (Some m2) = Some m2') *) - (* : *) - (* ZMap.get ofs (Mem.mem_contents m1') !! b = ZMap.get (ofs + ofsd) (Mem.mem_contents m2') !! b'. *) - (* Proof. *) - (* revert WF CHG m1 m1' m2 m2' PERM1 PERM2 APPD1 APPD2. induction d; intros. *) - (* { inv CHG. } *) - (* rewrite mem_delta_apply_cons in APPD1. rewrite mem_delta_apply_inj_cons in APPD2. inv WF. rename H1 into WF1, H2 into WF2. inv CHG. *) - (* 2:{ specialize (IHd WF2 H0). destruct a. *) - (* - destruct d0 as [[[[ch0 b0 ]ofs0] v0] cp0]. destruct (j b0) as [[b0' ofs0'] |] eqn:JB. *) - (* + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. *) - (* exploit mem_delta_apply_inj_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. *) - (* simpl in *. eapply IHd. 3,4: eauto. 1,2: eapply Mem.perm_store_1; eauto. *) - (* + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. simpl in *. eapply IHd. 3,4: eauto. all: auto. 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. 3,4: eauto. all: auto. *) - (* 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. 3,4: eauto. all: auto. *) - (* destruct (Mem.alloc m1 x y z) eqn:ALLOC. simpl in MEM1. 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. 3,4: eauto. all: auto. *) - (* eapply Mem.perm_free_1; eauto. left. intros CC. subst. congruence. *) - (* } *) - (* rename H0 into CHG. destruct (mem_delta_unchanged_or_changed d b ofs). *) - (* 2:{ specialize (IHd WF2 H). destruct a. *) - (* - destruct d0 as [[[[ch0 b0 ]ofs0] v0] cp0]. destruct (j b0) as [[b0' ofs0'] |] eqn:JB. *) - (* + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. *) - (* exploit mem_delta_apply_inj_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. *) - (* simpl in *. eapply IHd. 3,4: eauto. 1,2: eapply Mem.perm_store_1; eauto. *) - (* + exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. simpl in *. eapply IHd. 3,4: eauto. all: auto. 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. 3,4: eauto. all: auto. *) - (* 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. 3,4: eauto. all: auto. *) - (* destruct (Mem.alloc m1 x y z) eqn:ALLOC. simpl in MEM1. 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. 3,4: eauto. all: auto. *) - (* eapply Mem.perm_free_1; eauto. left. intros CC. subst. congruence. *) - (* } *) - (* rename H into UNCHG. clear IHd. *) - (* { destruct a. *) - (* - destruct d0 as [[[[ch0 b0] ofs0] v0] cp0]. destruct CHG as [CHG0 CHG1]. subst b0. rewrite INJ in APPD2. *) - (* exploit mem_delta_apply_some. eapply APPD1. intros (mi1 & MEM1). rewrite MEM1 in APPD1. exploit mem_delta_apply_inj_some. eapply APPD2. intros (mi2 & MEM2). rewrite MEM2 in APPD2. *) - (* simpl in *. *) - (* eapply mem_delta_unchanged_on in APPD1. exploit (Mem.unchanged_on_contents _ _ _ APPD1 b ofs); auto. *) - (* { eapply Mem.perm_store_1; eauto. } *) - (* intros. rewrite H; clear H. *) - (* eapply mem_delta_inj_unchanged_on in APPD2; auto. exploit (Mem.unchanged_on_contents _ _ _ APPD2 b' (ofs + ofsd)); auto. *) - (* { right. exists b, ofsd. split; auto. replace (ofs + ofsd - ofsd) with ofs by lia. auto. } *) - (* { eapply Mem.perm_store_1; eauto. } *) - (* intros. rewrite H; clear H. *) - (* eapply mem_store_same_upto_ofs; eauto. *) - (* - destruct d0 as [[[w x] y] z]. simpl in *. destruct CHG as [CHG0 CHG1]. subst w. rewrite WF1 in INJ. inv INJ. *) - (* - destruct d0 as [[x y] z]. simpl in *. inv CHG. *) - (* - destruct d0 as [[[w x] y] z]. simpl in *. inv CHG. rewrite WF1 in INJ. inv INJ. *) - (* } *) - (* 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 - (j: meminj) m0 m0' - (WINJ0: winject j m0 m0') + ge cp0 m0 m0' + (WINJ0: winject (meminj_public ge) m0 m0') (d: mem_delta) - (DWF: mem_delta_inj_wf j d) m1 (APPD: mem_delta_apply d (Some m0) = Some m1) : - exists m1', (mem_delta_apply_inj j d (Some m0') = Some m1') /\ (winject j m1 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 DWF m1 APPD. induction d; intros. - { inv APPD. simpl. exists m0'. split; auto. } - inv DWF. rename H1 into DWF1, H2 into DWF0. rewrite mem_delta_apply_cons in APPD. rewrite mem_delta_apply_inj_cons. - destruct a. - - destruct d0 as ((((ch & b) & ofs) & v) & cp). exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. - destruct (j b) as [[b' ofs']|] eqn:JB. - + exploit store_mapped_winject; eauto. instantiate (1:=v). intros (mi0 & MEM' & WINJ1). specialize (IHd _ _ WINJ1 DWF0 _ APPD). destruct IHd as (m1' & APPD' & WINJ'). - simpl in *. rewrite MEM'. eauto. - + exploit store_unmapped_winject; eauto. - - destruct d0 as (((b & ofs) & mvs) & cp). exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. exploit storebytes_unmapped_winject; eauto. - - destruct d0 as ((cp & lo) & hi). exploit mem_delta_apply_some. eauto. intros (mi & MEM). rewrite MEM in APPD. simpl in *. - 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. exploit free_left_winject; eauto. + 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 - j d - (DWF: mem_delta_inj_wf j d) + cp j d + (DWF: mem_delta_inj_wf cp j d) m0 m1 (APPD : mem_delta_apply d (Some m0) = Some m1) b ofs @@ -944,6 +1031,7 @@ Section PROOFS. { 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. @@ -966,40 +1054,41 @@ Section PROOFS. Qed. Lemma mem_delta_apply_establish_inject - (k j: meminj) m0 m0' + (ge: Senv.t) (k: meminj) m0 m0' (INJ: Mem.inject k m0 m0') - (INCR: inject_incr j k) - (STRICT: meminj_strict j) - (NALLOC: meminj_not_alloc j m0) - (d: mem_delta) - (DWF: mem_delta_inj_wf j d) + (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 j m1) + (FO: meminj_first_order (meminj_public ge) m1) : - exists m1', (mem_delta_apply_inj j d (Some m0') = Some m1') /\ (Mem.inject j m1 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; auto. + 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 (j b1 = None). + { destruct (Pos.ltb_spec0 b1 (Mem.nextblock m0)); auto. exfalso. assert ((meminj_public ge) b1 = None). { eapply NALLOC. lia. } congruence. } - intros PERM0. - destruct (mem_delta_unchanged_or_changed d b1 ofs). - - exploit mem_delta_unchanged_on; eauto. intros UNCHG1. exploit mem_delta_inj_unchanged_on; eauto. intros UNCHG2. + 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. - 2:{ right. exists b1, delta. split; auto. replace (ofs + delta - delta) with ofs by lia. auto. } - { inv INJ. inv mi_inj. specialize (mi_memval _ _ _ _ (INCR _ _ _ H) PERM0). eapply loc_first_order_always_memval_inject; eauto. - exploit FO. erewrite H. congruence. eauto. unfold loc_first_order; intros. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1) eqn:MEMV1; try contradiction. + { 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. } - { inv WINJ. inv mwi_inj. eapply mwi_perm; eauto. } - - rename H1 into CHG. erewrite <- mem_delta_changed_only_by_store; eauto. - { exploit FO; eauto. rewrite H. congruence. intros. unfold loc_first_order in H1. destruct (ZMap.get ofs (Mem.mem_contents m1) !! b1); try contradiction. constructor. } - { inv WINJ. inv mwi_inj. eapply mwi_perm; 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 MEMDELTA. +End PROOFS. From 00e0ed765f4c4d58bb7d29e3c7d0cc390b68d392 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 10 Aug 2023 18:20:31 +0200 Subject: [PATCH 111/174] WIP --- security/BtInfoAsm.v | 2 ++ 1 file changed, 2 insertions(+) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index de222c82ca..1088583a41 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -200,6 +200,7 @@ Section IR. Definition ir_state := option (block * mem * ir_conts)%type. + (* TODO *) Variant ir_step (ge: Asm.genv) : ir_state -> bundle_event -> ir_state -> Prop := | ir_step_cross_call_internal cur m1 ik @@ -213,6 +214,7 @@ Section IR. (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) + (* (PUB: public_first_order ge m1) *) (TR: call_trace_cross ge cp cp' b vargs (sig_args sg) tr id evargs) : ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg None) (Some (b, m1, (ir_cont cur) :: ik)) From ef7eb9b0af17b1034306e6cee34f187d50f471b0 Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 11 Aug 2023 17:17:17 +0200 Subject: [PATCH 112/174] WIP --- security/BtInfoAsm.v | 322 ++++++++++++++++++++++++++----------------- 1 file changed, 194 insertions(+), 128 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 1088583a41..02b210ae6b 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -56,9 +56,10 @@ 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: option mem_delta) + (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) @@ -68,7 +69,7 @@ Section BUNDLE. Definition unbundle (be: bundle_event): trace := match be with - | Bundle_call tr _ _ _ _ | Bundle_return tr _ | Bundle_builtin tr _ _ _ => tr + | Bundle_call tr _ _ _ _ | Bundle_return tr _ _ | Bundle_builtin tr _ _ _ => tr end. Fixpoint unbundle_trace (btr: bundle_trace) : trace := @@ -200,7 +201,6 @@ Section IR. Definition ir_state := option (block * mem * ir_conts)%type. - (* TODO *) Variant ir_step (ge: Asm.genv) : ir_state -> bundle_event -> ir_state -> Prop := | ir_step_cross_call_internal cur m1 ik @@ -214,10 +214,12 @@ Section IR. (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) - (* (PUB: public_first_order ge m1) *) (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) : - ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg None) (Some (b, m1, (ir_cont cur) :: ik)) + ir_step ge (Some (cur, m1, ik)) (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 @@ -234,8 +236,11 @@ Section IR. (* 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) : - ir_step ge (Some (cur, m1, ik)) (Bundle_return tr evretv) (Some (next, m1, ik_tl)) + ir_step ge (Some (cur, m1, ik)) (Bundle_return tr evretv d) (Some (next, m2, ik_tl)) | ir_step_intra_call_external cur m1 m2 ik tr id evargs sg @@ -248,21 +253,21 @@ Section IR. (INTRA: Genv.type_of_call ge cp_cur cp_ext = Genv.InternalCall) (SIG: sg = ef_sig ef) d m1' - (MEM: mem_delta_apply_inj (meminj_public ge) d (Some m1) = Some 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) : - ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg (Some d)) (Some (cur, m2, ik)) + ir_step ge (Some (cur, m1, ik)) (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)) d m1' - (MEM: mem_delta_apply_inj (meminj_public ge) d (Some m1) = Some 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) \/ @@ -285,7 +290,7 @@ Section IR. (SIG: sg = ef_sig ef) (TR: call_trace_cross ge cp cp' b vargs (sig_args sg) tr id evargs) : - ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg None) None + ir_step ge (Some (cur, m1, ik)) (Bundle_call tr id evargs sg []) None | ir_step_cross_call_external2 (* early cut at call-ext_call *) cur m1 ik @@ -302,14 +307,14 @@ Section IR. (TR1: call_trace_cross ge cp cp' b vargs (sig_args sg) tr1 id evargs) (* external function part *) d m1' - (MEM: mem_delta_apply_inj (meminj_public ge) d (Some m1) = Some 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) : - ir_step ge (Some (cur, m1, ik)) (Bundle_call (tr1 ++ tr2) id evargs sg (Some d)) None + ir_step ge (Some (cur, m1, ik)) (Bundle_call (tr1 ++ tr2) id evargs sg d) None | ir_step_cross_call_external3 (* early cut at call-ext_call *) cur m1 ik @@ -326,7 +331,7 @@ Section IR. (TR1: call_trace_cross ge cp cp' b vargs (sig_args sg) tr1 id evargs) (* external function part *) d m1' - (MEM: mem_delta_apply_inj (meminj_public ge) d (Some m1) = Some 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) \/ @@ -339,7 +344,7 @@ Section IR. (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) : - ir_step ge (Some (cur, m1, ik)) (Bundle_call (tr1 ++ tr2 ++ tr3) id evargs sg (Some d)) (Some (cur, m2, ik)). + ir_step ge (Some (cur, m1, ik)) (Bundle_call (tr1 ++ tr2 ++ tr3) id evargs sg d) (Some (cur, m2, ik)). End IR. @@ -496,50 +501,6 @@ Section FROMASM. instantiate (1:=lo). lia. 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 (meminj_public ge) d) - (DELTA1: mem_delta_apply d (Some m0) = Some m) - : - exists d', (mem_delta_inj_wf (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 ?ofs ?v ?cp = _ |- _ => - exists (d ++ [mem_delta_kind_store (ch, b, ofs, v, cp)]); split - end; - [apply Forall_app; split; [auto | constructor; simpl; 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. - - 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. - Lemma public_not_freeable_store ge m1 (NFREE: public_not_freeable ge m1) @@ -701,6 +662,8 @@ Section FROMASM. 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. @@ -728,6 +691,53 @@ Section FROMASM. (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. @@ -798,11 +808,11 @@ Section INVS. : match_stack ge (ir_cont next :: ik_tl) (Stackframe b cp sg v ofs :: sk_tl). - Definition match_mem (ge: Senv.t) (k: meminj) (d: mem_delta) (m_a0 m_i m_a1: mem): Prop := + 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 j d) /\ (mem_delta_apply d (Some m_a0) = Some 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 := @@ -810,7 +820,7 @@ Section INVS. | 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 k d m_a0 m_i m_a) + (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. @@ -908,19 +918,20 @@ Section PROOF. Qed. Lemma public_rev_perm_delta_apply_inj - d ge m m_i m_i' + d ge m m_i m_i' cp (PRP: public_rev_perm ge m m_i) - (APPD: mem_delta_apply_inj (meminj_public ge) d (Some m_i) = Some 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. - { ss; clarify. } - rewrite mem_delta_apply_inj_cons in APPD. des_ifs; clarify; eauto. - exploit mem_delta_apply_inj_some; eauto. intros (m1 & STORE). rewrite STORE in APPD. + { 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 b1). des_ifs. intros. - eapply PRP. ss. eapply Mem.perm_store_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 @@ -975,23 +986,23 @@ Section PROOF. Qed. Lemma match_mem_external_call_establish1 - (ge: genv) k d m_a0 m_i m - (MEM: match_mem ge k d m_a0 m_i m) + (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_inj (meminj_public ge) d (Some m_i) = Some m1) /\ + (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 k2 [] m' m2 m' /\ Val.inject k2 res res') + (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. } + (* { 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. @@ -999,7 +1010,7 @@ Section PROOF. { 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 f' [] m' m_i'' m'). + 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. @@ -1065,7 +1076,7 @@ Section PROOF. (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 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'' @@ -1108,15 +1119,15 @@ Section PROOF. Qed. Lemma match_mem_external_call_establish2 - ge k d m_a0 m_i m - (MEM: match_mem ge k d m_a0 m_i m) + 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 k d m_a0 m_i m') + (match_mem ge cp k d m_a0 m_i m') . Proof. destruct MEM as (MEM0 & MEM1 & MEM2 & MEM3 & MEM4 & MEM5 & MEM6). @@ -1141,17 +1152,17 @@ Section PROOF. Qed. Lemma match_mem_external_call_establish - (ge: genv) k d m_a0 m_i m - (MEM: match_mem ge k d m_a0 m_i m) + (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_inj (meminj_public ge) d' (Some m_i) = Some m1) /\ + (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 k2 d2 m_a02 m2 m' /\ (Val.inject k2 res res' \/ (res = res'))) + (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]. @@ -1171,7 +1182,7 @@ Section PROOF. (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 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 @@ -1184,7 +1195,7 @@ Section PROOF. 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 k' d' m_a0' m_i' m_a') /\ + (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. @@ -1202,7 +1213,7 @@ Section PROOF. - (* extcall is unknown *) exploit match_mem_external_call_establish1; eauto. unfold match_mem; splits; eauto. intros. des. - exists ([Bundle_call t ef_id (vals_to_eventvals ge args) (ef_sig ef0) (Some d)]). + exists ([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. @@ -1215,24 +1226,24 @@ Section PROOF. 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 ([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 |} (Some [])]). + exists ([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. } - { simpl. eauto. } + { 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]. inv EXTCALL. inv H; simpl in *; clarify. - exists ([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 |} (Some [])]). + exists ([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. } - { simpl. eauto. } + { ss. } { instantiate (2:=[Vptr b0 ofs; Val.load_result chunk v]). simpl. econstructor. econstructor 1; eauto. rewrite val_load_result_idem. auto. } @@ -1246,23 +1257,23 @@ Section PROOF. { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. - exists ([Bundle_call [Event_annot text args0] ef_id (vals_to_eventvals ge args) {| sig_args := targs; sig_res := Tvoid; sig_cc := cc_default |} (Some [])]). + exists ([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. } - { simpl. eauto. } + { ss. } { simpl. econstructor. auto. } { simpl. right. split; auto. econs; eauto. econs. auto. } splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. - exists ([Bundle_call [Event_annot text [arg]] ef_id [val_to_eventval ge res] {| sig_args := [targ]; sig_res := targ; sig_cc := cc_default |} (Some [])]). + exists ([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. } - { simpl. eauto. } + { ss. } { simpl. econstructor. eauto. } { simpl. right. split; auto. econs; eauto. econs. auto. } { simpl. auto. } @@ -1283,9 +1294,11 @@ Section PROOF. 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_store (chunk, b0, (Ptrofs.unsigned ofs), v, cp)]), m_a0, m_i, m'. simpl. splits; auto. econstructor 1. 2: eauto. unfold match_mem. splits; auto. + 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. simpl. auto. } + { 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. } } @@ -1298,7 +1311,8 @@ Section PROOF. } { setoid_rewrite Forall_app. split; auto. econs; auto. { simpl. 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. @@ -1356,7 +1370,7 @@ Section PROOF. 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 k' d' m_a0' m_i' m'). + (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). @@ -1379,7 +1393,7 @@ Section PROOF. 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. - { simpl. eauto. } + { 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. } @@ -1390,7 +1404,7 @@ Section PROOF. 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. - { simpl. eauto. } + { ss. } { instantiate (2:=[Vptr b0 ofs0; Val.load_result chunk v]). simpl. econstructor. econstructor 1; eauto. rewrite val_load_result_idem. auto. } @@ -1408,7 +1422,7 @@ Section PROOF. 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. - { simpl. eauto. } + { ss. } { simpl. econstructor. auto. } { simpl. right. split; auto. econs; eauto. econs. auto. } splits; auto. @@ -1418,7 +1432,7 @@ Section PROOF. 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. - { simpl. eauto. } + { ss. } { simpl. econstructor. eauto. } { simpl. right. split; auto. econs; eauto. econs. auto. } { simpl. auto. } @@ -1438,9 +1452,11 @@ Section PROOF. 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_store (chunk, b0, (Ptrofs.unsigned ofs0), v, cp)]), m_a0, m_i. simpl. splits; auto. econstructor 1. unfold match_mem. splits; auto. + 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. simpl. auto. } + { 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. } } @@ -1453,7 +1469,8 @@ Section PROOF. } { setoid_rewrite Forall_app. split; auto. econs; auto. { simpl. 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. @@ -1516,7 +1533,7 @@ Section PROOF. (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 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') @@ -1600,7 +1617,7 @@ Section PROOF. (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 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'' @@ -1613,32 +1630,56 @@ Section PROOF. (** step --- ReturnState *) inv STEP. inv EV; simpl in *. { rewrite CCC in H. congruence with H. } - clear 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:=k). instantiate (3:=m_a0). instantiate (2:=d). - instantiate (1:=Some (next, m_i, ik_tl)). simpl. splits; 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. } + { rr; splits; auto. eapply meminj_not_alloc_delta; eauto. ss. eapply public_rev_perm_delta_apply_inj; eauto. + } } + (* { instantiate (4:=k). instantiate (3:=m_a0). instantiate (2:=d). *) + (* 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. } *) + (* } *) intros (btr & ist' & UTR & ISTAR'). - exists ((Bundle_return [Event_return (Genv.find_comp_ignore_offset ge (rs PC)) (Genv.find_comp ge (Vptr cur Ptrofs.zero)) res] res) :: btr), ist'. + exists ((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'. + (* exists ((Bundle_return [Event_return (Genv.find_comp_ignore_offset ge (rs PC)) (Genv.find_comp ge (Vptr cur Ptrofs.zero)) res] res) :: 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. } + { 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 @@ -1663,7 +1704,7 @@ Section PROOF. (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 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') @@ -1720,7 +1761,7 @@ Section PROOF. (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 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'' @@ -1787,7 +1828,7 @@ Section PROOF. (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 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'' @@ -1830,8 +1871,9 @@ Section PROOF. 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') + 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 @@ -1840,12 +1882,7 @@ Section PROOF. (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' + 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) @@ -1869,7 +1906,11 @@ Section PROOF. 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. eapply MEM4. eapply MEM5. intros (d' & MEM4' & MEM5'). + 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 *) @@ -1886,6 +1927,9 @@ Section PROOF. 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. } } @@ -1906,6 +1950,9 @@ Section PROOF. } { 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')). @@ -2037,7 +2084,7 @@ Section PROOF. { destruct ist as [[[cur m_i] ik] |]; ss. destruct MTST as (WFIR0 & WFIR1 & MTST0 & MTST1 & MTST2 & MTST3). destruct WFASM as [WFASM0 WFASM1]. - assert (Genv.CrossCompartmentCall <> Genv.InternalCall) by congruence. specialize (CALLSIG H); clear H. des. + specialize (CALLSIG eq_refl). des. exploit exec_instr_is_call; eauto. clear H2 H3 H4. intros (RSX & MEM). subst m'. destruct fd. (* calling internal function *) @@ -2049,12 +2096,29 @@ Section PROOF. 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. } - exists ([Bundle_call [Event_call (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) i0 vl] i0 vl (fn_sig f0) None]). eexists. split. + 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 ([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. + } } rewrite H0 in RSX. simpl in RSX. inv RSX. eapply IH. 4: eapply STAR. all: auto. @@ -2068,6 +2132,8 @@ Section PROOF. - 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). From 6c1db3dd909716120d58d0f6e3e38d218a0121ae Mon Sep 17 00:00:00 2001 From: ldj Date: Sat, 12 Aug 2023 12:40:04 +0200 Subject: [PATCH 113/174] WIP --- security/BtInfoAsm.v | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 02b210ae6b..92797e32fc 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -2147,7 +2147,7 @@ Section PROOF. intros (cp & cp' & sg & FACT1 & FACT2 & FACT3 & FACT4 & FACT5 & FACT6 & FACT7 & FACT8). subst. inv STAR; ss. (* subcase 1 *) - { exists ([Bundle_call [Event_call (comp_of f) (Genv.find_comp ge (Vptr b0 Ptrofs.zero)) i0 vl] i0 vl (ef_sig e) None]). eexists. ss. split; auto. + { exists ([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. } @@ -2169,7 +2169,7 @@ Section PROOF. destruct x0 as (d' & m1 & m2 & res' & EFACT1 & EFACT2 & EFACT3 & (k2 & d2 & m_a02 & MM)). inv STAR. (* subcase 2 *) - { exists ([Bundle_call ([Event_call (comp_of f) (Genv.find_comp ge (Vptr b2 Ptrofs.zero)) i0 vl] ++ t1) i0 vl (ef_sig ef) (Some d')]). eexists. split; auto. + { exists ([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. @@ -2191,7 +2191,7 @@ Section PROOF. } eapply asm_to_ir_compose. 2:{ instantiate (1:=t3). rewrite app_comm_cons. setoid_rewrite app_assoc. eauto. } - exists ([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) (Some d')]). eexists. split. + exists ([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. From daf18912add0b4c13d41091a8884e3c8b2a6a8f0 Mon Sep 17 00:00:00 2001 From: ldj Date: Sat, 12 Aug 2023 13:10:44 +0200 Subject: [PATCH 114/174] fixed --- security/BtInfoAsm.v | 111 +++++++++++++++++++++++++++---------------- 1 file changed, 70 insertions(+), 41 deletions(-) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 92797e32fc..0e273af2a4 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -65,13 +65,17 @@ Section BUNDLE. (d: mem_delta) . - Definition bundle_trace := list bundle_event. + Definition bundle_trace := list (ident * bundle_event). - Definition unbundle (be: bundle_event): trace := + Definition unbundle_ev (be: (bundle_event)): trace := match be with - | Bundle_call tr _ _ _ _ | Bundle_return tr _ _ | Bundle_builtin tr _ _ _ => tr + | (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) @@ -95,13 +99,15 @@ Section BUNDLE. eauto. Qed. - Inductive istar {genv state : Type} (step : genv -> state -> bundle_event -> state -> Prop) (ge : genv) : state -> bundle_trace -> state -> Prop := + 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 : bundle_event) (s2 : state) (t2 : bundle_trace) (s3 : state) (t : bundle_trace), + | 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 -> bundle_event -> state -> Prop) ge + genv state (step: genv -> state -> _ -> state -> Prop) ge s1 t1 s2 (ISTAR1: istar step ge s1 t1 s2) t2 s3 @@ -201,7 +207,7 @@ Section IR. Definition ir_state := option (block * mem * ir_conts)%type. - Variant ir_step (ge: Asm.genv) : ir_state -> bundle_event -> ir_state -> Prop := + 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 @@ -218,8 +224,10 @@ Section IR. 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)) (Bundle_call tr id evargs sg d) (Some (b, m2, (ir_cont cur) :: ik)) + 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 @@ -239,8 +247,10 @@ Section IR. 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)) (Bundle_return tr evretv d) (Some (next, m2, ik_tl)) + 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 @@ -259,8 +269,10 @@ Section IR. (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)) (Bundle_call tr id evargs sg d) (Some (cur, m2, ik)) + 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 @@ -273,8 +285,10 @@ Section IR. (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)) (Bundle_builtin tr ef evargs d) (Some (cur, m2, ik)) + 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 @@ -289,8 +303,10 @@ Section IR. (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)) (Bundle_call tr id evargs sg []) None + 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 @@ -313,8 +329,10 @@ Section IR. (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)) (Bundle_call (tr1 ++ tr2) id evargs sg d) None + 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 @@ -343,8 +361,10 @@ Section IR. 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)) (Bundle_call (tr1 ++ tr2 ++ tr3) id evargs sg d) (Some (cur, m2, ik)). + ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_call (tr1 ++ tr2 ++ tr3) id evargs sg d) (Some (cur, m2, ik)). End IR. @@ -1200,6 +1220,11 @@ Section PROOF. (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 *) @@ -1213,7 +1238,7 @@ Section PROOF. - (* extcall is unknown *) exploit match_mem_external_call_establish1; eauto. unfold match_mem; splits; eauto. intros. des. - exists ([Bundle_call t ef_id (vals_to_eventvals ge args) (ef_sig ef0) (d)]). + 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. @@ -1226,7 +1251,7 @@ Section PROOF. 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 ([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 ([(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. @@ -1238,7 +1263,7 @@ Section PROOF. splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. - exists ([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 ([(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. @@ -1257,7 +1282,7 @@ Section PROOF. { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. - exists ([Bundle_call [Event_annot text args0] ef_id (vals_to_eventvals ge args) {| sig_args := targs; sig_res := Tvoid; sig_cc := cc_default |} ([])]). + 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. @@ -1268,7 +1293,7 @@ Section PROOF. splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. - exists ([Bundle_call [Event_annot text [arg]] ef_id [val_to_eventval ge res] {| sig_args := [targ]; sig_res := targ; sig_cc := cc_default |} ([])]). + 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. @@ -1375,12 +1400,17 @@ Section 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 ([Bundle_builtin t1 ef (vals_to_eventvals ge vargs) d]). + 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. @@ -1389,7 +1419,7 @@ Section PROOF. unfold external_call_known_observables in ECKO. des_ifs; simpl in *. { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. - exists ([Bundle_builtin [Event_vload chunk id ofs0 ev] (EF_vload cp chunk) [EVptr_global id ofs0] []]). + 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. @@ -1400,7 +1430,7 @@ Section PROOF. splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. - exists ([Bundle_builtin [Event_vstore chunk id ofs0 ev] (EF_vstore cp chunk) [EVptr_global id ofs0; ev] []]). + 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. @@ -1418,7 +1448,7 @@ Section PROOF. { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } { destruct ECKO as [_ OBS]. inv EXTCALL; clarify. } { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. - exists ([Bundle_builtin [Event_annot text args] (EF_annot cp kind text targs) (vals_to_eventvals ge vargs) []]). + 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. @@ -1428,7 +1458,7 @@ Section PROOF. splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. - exists ([Bundle_builtin [Event_annot text [arg]] (EF_annot_val cp kind text targ) [val_to_eventval ge vres] []]). + 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. @@ -1626,6 +1656,11 @@ Section PROOF. : 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 *. @@ -1652,16 +1687,8 @@ Section PROOF. { rr; splits; auto. eapply meminj_not_alloc_delta; eauto. ss. eapply public_rev_perm_delta_apply_inj; eauto. } } - (* { instantiate (4:=k). instantiate (3:=m_a0). instantiate (2:=d). *) - (* 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. } *) - (* } *) intros (btr & ist' & UTR & ISTAR'). - exists ((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'. - (* exists ((Bundle_return [Event_return (Genv.find_comp_ignore_offset ge (rs PC)) (Genv.find_comp ge (Vptr cur Ptrofs.zero)) res] res) :: btr), ist'. *) + 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. @@ -2086,6 +2113,11 @@ Section PROOF. 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. @@ -2103,7 +2135,7 @@ Section PROOF. eapply CHECKPUB; eauto. apply Senv.invert_find_symbol; auto. } intros (m_i' & APPD & MEMINJ). - exists ([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. + 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. } @@ -2119,6 +2151,7 @@ Section PROOF. 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. @@ -2147,7 +2180,7 @@ Section PROOF. intros (cp & cp' & sg & FACT1 & FACT2 & FACT3 & FACT4 & FACT5 & FACT6 & FACT7 & FACT8). subst. inv STAR; ss. (* subcase 1 *) - { exists ([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. + { 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. } @@ -2169,7 +2202,7 @@ Section PROOF. destruct x0 as (d' & m1 & m2 & res' & EFACT1 & EFACT2 & EFACT3 & (k2 & d2 & m_a02 & MM)). inv STAR. (* subcase 2 *) - { exists ([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. + { 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. @@ -2191,7 +2224,7 @@ Section PROOF. } eapply asm_to_ir_compose. 2:{ instantiate (1:=t3). rewrite app_comm_cons. setoid_rewrite app_assoc. eauto. } - exists ([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. + 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. @@ -2277,8 +2310,6 @@ Section INIT. wf_ge (Genv.globalenv p). Proof. unfold wf_ge; eauto. Qed. - (* Definition wf_main {F V} (p: AST.program (AST.fundef F) V) := *) - (* 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) /\ (fn_sig f = signature_main)). *) 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)). @@ -2319,13 +2350,11 @@ Section INIT. exists ist, ir_initial_state p ist. Proof. unfold wf_main in WFMAIN. des. inv INIT. - (* unfold fundef in *. *) exists (Some (b, m0, [])). econs; eauto. Qed. Lemma match_state_initial_state p ast ist - (* (WFMAIN: wf_main p) *) (WFMAINSIG: wf_main_sig p) (INITA: Asm.initial_state p ast) (INITI: ir_initial_state p ist) From f4062cc69d936a04c95191d80638f9772b137eaa Mon Sep 17 00:00:00 2001 From: ldj Date: Sun, 13 Aug 2023 18:40:21 +0200 Subject: [PATCH 115/174] WIP --- security/Backtranslation.v | 363 ++++++++++++------------------------- 1 file changed, 117 insertions(+), 246 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 1c2daeb384..ebcf9f5a29 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -55,9 +55,8 @@ Section Backtranslation. Ltac take_step' := econstructor; [econstructor; simpl_expr' | | traceEq]; simpl. - Lemma switch_clause_spec p (cnt: ident) f e le m b (n: int64) (n': Z) s_then s_else: + 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 - let ge := globalenv p in e ! cnt = None -> Genv.find_symbol ge cnt = Some b -> Mem.valid_access m Mint64 b 0 Writable (Some cp) -> @@ -65,11 +64,11 @@ Section Backtranslation. if Int64.eq n (Int64.repr n') then exists m', Mem.storev Mint64 m (Vptr b Ptrofs.zero) (Vlong (Int64.add n Int64.one)) cp = Some m' /\ - Star (Clight.semantics1 p) (State f (switch_clause cnt n' s_then s_else) Kstop e le m) E0 (State f s_then Kstop e le 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 cnt n' s_then s_else) Kstop e le m) E0 (State f s_else Kstop e le m). + 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 ge. + 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. @@ -96,30 +95,27 @@ Section Backtranslation. Qed. Lemma switch_spec_else - p (cnt: ident) f (e: env) le m b (n: Z) ss s_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 ge := globalenv p in let cp := comp_of f in e ! cnt = None -> Genv.find_symbol ge cnt = Some b -> - (* e ! (bt_env.(local_counter) cp) = Some (b, type_counter) -> *) - (* Mem.valid_access m Mint64 b 0 Writable (Some cp) -> *) Mem.loadv Mint64 m (Vptr b Ptrofs.zero) (Some cp) = Some (Vlong (Int64.repr n)) -> - Star (Clight.semantics1 p) - (State f (switch cnt ss s_else) Kstop e le m) + 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 ge. unfold switch. destruct RANGE as [RA1 RA2]. + intros; subst cp. unfold switch. destruct RANGE as [RA1 RA2]. assert (G: forall n', (Z.of_nat (length ss)) <= n' -> n' <= n -> - Star (Clight.semantics1 p) - (State f (snd (fold_right (switch_add_statement cnt) (n', s_else) ss)) Kstop e le m) + 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 Kstop e le m)). + (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 RA1, LE1. rewrite fst_switch, <- Z.sub_succ_r. @@ -142,11 +138,10 @@ Section Backtranslation. Let nat64 n := Int64.repr (Z.of_nat n). Lemma switch_spec - p (cnt: ident) f (e: env) le m b + (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 ge := globalenv p in let cp := comp_of f in e ! cnt = None -> Genv.find_symbol ge cnt = Some b -> @@ -154,10 +149,10 @@ Section Backtranslation. 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 (Clight.semantics1 p) - (State f (switch cnt (ss ++ s :: ss') s_else) Kstop e le m) + star (step1) ge + (State f (switch cnt (ss ++ s :: ss') s_else) k e le m) E0 - (State f s Kstop e le m'). + (State f s k e le m'). Proof. intros. assert (Eswitch : @@ -172,7 +167,7 @@ Section Backtranslation. rewrite A. reflexivity. } destruct Eswitch as [s_else' ->]. clear s_else. rename s_else' into s_else. - exploit (switch_clause_spec p cnt f e le m b (nat64 (length ss)) (Z.of_nat (length ss)) s s_else); auto. + 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. @@ -421,8 +416,8 @@ Section Backtranslation. Variable ge: Senv.t. (* Type: Tvoid has size 1, which is what we want *) - Definition expr_of_addr (id: ident) (ofs: Z): expr := - ptr_of_id_ofs id (Ptrofs.repr ofs). + 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 @@ -474,13 +469,6 @@ Section Backtranslation. Section CODE. (** converting *informative* trace to code **) - (* TODO list: -cross-call/return -> check current cp - public global blocks are fo -ir: at cross-call/return, invoke a delta -change to Mem.storev (for Ptrofs.unsigned ofs) - - *) - Variable ge: Clight.genv. Lemma ptr_of_id_ofs_eval @@ -503,35 +491,58 @@ change to Mem.storev (for Ptrofs.unsigned ofs) erewrite Ptrofs.agree32_of_ints_eq; auto. apply Ptrofs.agree32_to_int; auto. Qed. - Definition code_mem_delta_store (d: mem_delta_store): statement := - let '(ch, b, ofs, v, cp) := d in - if (wf_chunk_val_b ch v) then - 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 => Sassign (Ederef (expr_of_addr id ofs) ty) ve - | _, _ => Sskip - end - | None => Sskip - end - else Sskip. - - Definition code_mem_delta_kind (d: mem_delta_kind): statement := + 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_store dd => code_mem_delta_store dd + | 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). + + Lemma code_mem_delta_cons + cp k d sn + : + code_mem_delta cp (k :: d) sn = + Ssequence (code_mem_delta_kind cp k) (code_mem_delta cp d sn). + Proof. unfold code_mem_delta. ss. Qed. + + Lemma code_mem_delta_app + cp d1 d2 sn + : + code_mem_delta cp (d1 ++ d2) sn = (code_mem_delta cp d1 (code_mem_delta 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 ch ty v e - (WF: wf_chunk_val ch v) + (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. + 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). @@ -541,7 +552,7 @@ change to Mem.storev (for Ptrofs.unsigned ofs) Lemma sem_cast_chunk_val m ch ty v e - (WF: wf_chunk_val ch v) + (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) @@ -549,7 +560,7 @@ change to Mem.storev (for Ptrofs.unsigned ofs) 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, wf_chunk_val_b in WF. des_ifs; ss; inv CT; econs. + 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 := @@ -565,7 +576,7 @@ change to Mem.storev (for Ptrofs.unsigned ofs) Lemma chunk_val_to_expr_eval ch v exp e cp le m (EXP: chunk_val_to_expr ge ch v = Some exp) - (WF: wf_chunk_val ch v) + (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. @@ -587,25 +598,26 @@ change to Mem.storev (for Ptrofs.unsigned ofs) intros (ty & TY). rewrite TY. unfold wf_chunk_val_b in WF. des_ifs; ss; eauto. Qed. - Lemma code_mem_delta_store_correct + Lemma code_mem_delta_storev_correct f k e le m m' d (WFE: wf_env ge e) - (STORE: mem_delta_apply_store (Some m) d = Some m') - (WF: wf_mem_delta_store_b ge (comp_of f) d) + (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_store d) k e le m) E0 (State f Sskip k e le m')). + step1 ge (State f (code_mem_delta_storev (comp_of f) d) k e le m) + E0 (State f Sskip k e le m'). Proof. - unfold wf_mem_delta_store_b in WF. des_ifs. rename m0 into ch, z into ofs. ss. - (* specialize (WFE i). rewrite H0 in WFE. *) + 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 i0). eapply chunk_val_to_expr_eval; eauto. - - instantiate (1:=cast_chunk_int ch i0). erewrite type_of_chunk_val_to_expr; eauto. + - 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. @@ -613,207 +625,66 @@ change to Mem.storev (for Ptrofs.unsigned ofs) + unfold Cop.sem_cast. ss. des_ifs. + unfold Cop.sem_cast. ss. des_ifs. - simpl_expr. eapply access_mode_chunk_to_type_wf; eauto. - (*** TODO *) - rewrite <- STORE. destruct ch; ss. - + rewrite Mem.store_int8_sign_ext. admit. - + rewrite Mem.store_int8_zero_ext. admit. - + rewrite Mem.store_int16_sign_ext. admit. - + rewrite Mem.store_int16_zero_ext. admit. - + admit. + 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. } - { eapply step_assign. - - econs. unfold expr_of_addr. eapply ptr_of_id_ofs_eval. admit. eapply Genv.invert_find_symbol; eauto. + { 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. admit. + - simpl_expr. eapply access_mode_chunk_to_type_wf; eauto. + apply Pos.eqb_eq in WF. clarify. } Qed. - Lemma code_mem_delta_kind_correct - d f k e le m m' + Lemma wf_mem_delta_storev_false_is_skip + cp d + (NWF: wf_mem_delta_storev_b ge cp d = false) + : + code_mem_delta_storev cp d = Sskip. + Proof. destruct d as [[[ch ptr] v] cp0]. ss. des_ifs. Qed. + + Lemma code_mem_delta_correct + f k e le m m' + d snext (WFE: wf_env ge e) - (DEL: code_mem_delta_kind d <> Sskip) - (STORE: mem_delta_apply [d] (Some m) = Some m') - (WF: mem_delta_kind_wf d) + (APPD: mem_delta_apply_wf ge (comp_of f) d (Some m) = Some m') : - (step1 ge (State f (code_mem_delta_kind d) k e le m) E0 (State f Sskip k e le m')). + (star step1 ge (State f (code_mem_delta (comp_of f) d snext) k e le m) + E0 (State f snext k e le m')). Proof. - destruct d; ss. des_ifs. clear DEL. ss. 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. admit. eapply Genv.invert_find_symbol; eauto. - - instantiate (1:=Vint i0). eapply chunk_val_to_expr_eval; eauto. - - ss. instantiate (1:=cast_chunk_int m0 i0). rename m0 into ch. erewrite type_of_chunk_val_to_expr; eauto. - unfold chunk_to_type in Heq0. destruct ch; ss; inv Heq0. - + 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. destruct m0; ss. - + rewrite Mem.store_int8_sign_ext. admit. - + rewrite Mem.store_int8_zero_ext. admit. - + rewrite Mem.store_int16_sign_ext. admit. - + rewrite Mem.store_int16_zero_ext. admit. - + admit. - } - { eapply step_assign. - - econs. unfold expr_of_addr. eapply ptr_of_id_ofs_eval. admit. 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. admit. - } + 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. - - - - -Mem.store_mem_contents: - forall (chunk : memory_chunk) (m1 : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) (m2 : mem), - Mem.store chunk m1 b ofs v cp = Some m2 -> Mem.mem_contents m2 = PMap.set b (Mem.setN (encode_val chunk v) ofs (Mem.mem_contents m1) !! b) (Mem.mem_contents m1) -Mem.valid_access = -fun (m : mem) (chunk : memory_chunk) (b : block) (ofs : Z) (p : permission) (cp : option compartment) => -Mem.range_perm m b ofs (ofs + size_chunk chunk) Cur p /\ Mem.can_access_block m b cp /\ (align_chunk chunk | ofs) - : mem -> memory_chunk -> block -> Z -> permission -> option compartment -> Prop -Mem.store = -fun (chunk : memory_chunk) (m : mem) (b : block) (ofs : Z) (v : val) (cp : compartment) => -match Mem.valid_access_dec m chunk b ofs Writable (Some cp) with -| left x => - Some - {| - Mem.mem_contents := PMap.set b (Mem.setN (encode_val chunk v) ofs (Mem.mem_contents m) !! b) (Mem.mem_contents m); - Mem.mem_access := Mem.mem_access m; - Mem.mem_compartments := Mem.mem_compartments m; - Mem.nextblock := Mem.nextblock m; - Mem.access_max := - (fun (chunk0 : memory_chunk) (m0 : mem) (b0 : block) (ofs0 : Z) (_ : val) (cp0 : compartment) (_ : Mem.valid_access m0 chunk0 b0 ofs0 Writable (Some cp0)) (b1 : positive) (ofs1 : Z) => - Memory.Mem.store_obligation_1 m0 b1 ofs1) chunk m b ofs v cp x; - Mem.nextblock_noaccess := - (fun (chunk0 : memory_chunk) (m0 : mem) (b0 : block) (ofs0 : Z) (_ : val) (cp0 : compartment) (_ : Mem.valid_access m0 chunk0 b0 ofs0 Writable (Some cp0)) (b1 : positive) - (ofs1 : Z) (k : perm_kind) (H0 : ~ Plt b1 (Mem.nextblock m0)) => Memory.Mem.store_obligation_2 m0 b1 ofs1 k H0) chunk m b ofs v cp x; - Mem.contents_default := - (fun (chunk0 : memory_chunk) (m0 : mem) (b0 : block) (ofs0 : Z) (v0 : val) (cp0 : compartment) (_ : Mem.valid_access m0 chunk0 b0 ofs0 Writable (Some cp0)) (b1 : positive) => - Memory.Mem.store_obligation_3 chunk0 m0 b0 ofs0 v0 b1) chunk m b ofs v cp x; - Mem.nextblock_compartments := - (fun (chunk0 : memory_chunk) (m0 : mem) (b0 : block) (ofs0 : Z) (_ : val) (cp0 : compartment) (_ : Mem.valid_access m0 chunk0 b0 ofs0 Writable (Some cp0)) (b1 : positive) => - Memory.Mem.store_obligation_4 m0 b1) chunk m b ofs v cp x - |} -| right _ => None -end - : memory_chunk -> mem -> block -> Z -> val -> compartment -> option mem - - - - unfold chunk_val_to_expr in CVE. rewrite CT in CVE. - destruct ch; ss; clarify. - - unfold chunk_val_to_expr in CVE. ss. des_ifs; ss; simpl_expr. - * admit. - * - - - - (* unfold chunk_to_type in CT. unfold chunk_val_to_expr in CVE. *) - (* unfold Cop.sem_cast. des_ifs. *) - - - (* destruct ch; destruct v; ss; eauto. simpl_expr. *) - - - (* TODO *) - - | step_assign: forall f a1 a2 k e le m loc ofs bf v2 v m', - eval_lvalue e (comp_of f) le m a1 loc ofs bf -> - eval_expr e (comp_of f) le m a2 v2 -> - Cop.sem_cast v2 (typeof a2) (typeof a1) m = Some v -> - assign_loc ge (comp_of f) (typeof a1) m loc ofs bf v m' -> - step (State f (Sassign a1 a2) k e le m) - E0 (State f Sskip k e le m') -Inductive assign_loc (ce : composite_env) (cp : compartment) (ty : type) (m : mem) (b : block) (ofs : ptrofs) : bitfield -> val -> mem -> Prop := - assign_loc_value : forall (v : val) (chunk : memory_chunk) (m' : mem), access_mode ty = By_value chunk -> Mem.storev chunk m (Vptr b ofs) v cp = Some m' -> assign_loc ce cp ty m b ofs Full v m' -Cop.sem_add = -fun (cenv : composite_env) (v1 : val) (t1 : type) (v2 : val) (t2 : type) (m : mem) => -match Cop.classify_add t1 t2 with -| Cop.add_case_pi ty si => Cop.sem_add_ptr_int cenv ty si v1 v2 -| Cop.add_case_pl ty => Cop.sem_add_ptr_long cenv ty v1 v2 -| Cop.add_case_ip si ty => Cop.sem_add_ptr_int cenv ty si v2 v1 -| Cop.add_case_lp ty => Cop.sem_add_ptr_long cenv ty v2 v1 -| Cop.add_default => - Cop.sem_binarith (fun (_ : signedness) (n1 n2 : int) => Some (Vint (Int.add n1 n2))) (fun (_ : signedness) (n1 n2 : int64) => Some (Vlong (Int64.add n1 n2))) - (fun n1 n2 : Floats.float => Some (Vfloat (Floats.Float.add n1 n2))) (fun n1 n2 : Floats.float32 => Some (Vsingle (Floats.Float32.add n1 n2))) v1 t1 v2 t2 m -end - : composite_env -> val -> type -> val -> type -> mem -> option val - - Definition code_bundle_call (tr: trace) (id: ident) (evargs: list eventval) (sg: signature) (omd: option mem_delta): statement := - let tys := from_sig_fun_data sg in - Scall None (Evar id (Tfunction tys.(dargs) tys.(dret) tys.(dcc))) (list_eventval_to_list_expr evargs). -Variant bundle_event : Type := - Bundle_call : trace -> ident -> list eventval -> signature -> option mem_delta -> bundle_event - | Bundle_return : trace -> eventval -> bundle_event - | Bundle_builtin : trace -> external_function -> list eventval -> mem_delta -> bundle_event. + 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)). - (* converting functions *) - Definition code_of_external (argsexpr: list expr) (ik: info_kind) := - match ik with - | info_builtin ef => - Sbuiltin None ef (dargs (from_sig_fun_data (ef_sig ef))) argsexpr - | info_external b sg => - match Genv.invert_symbol ge b with - | Some id => - let tys := from_sig_fun_data sg in - Scall None (Evar id (Tfunction (dargs tys) (dret tys) (dcc tys))) argsexpr - | None => Sskip - end - | _ => Sskip - end. - - Definition code_of_vload (ch: memory_chunk) (id: ident) (ofs: Ptrofs.int) (v: eventval) (ik: info_kind) := - let argsexpr := (ptr_of_id_ofs id ofs :: nil) in code_of_external argsexpr ik. - - Definition code_of_vstore (ch: memory_chunk) (id: ident) (ofs: Ptrofs.int) (v: eventval) (ik: info_kind) := - let argsexpr := ((ptr_of_id_ofs id ofs) :: (eventval_to_expr v) :: nil) in code_of_external argsexpr ik. - - Definition code_of_annot (str: string) (vs: list eventval) (ik: info_kind) := - let argsexpr := (list_eventval_to_list_expr vs) in code_of_external argsexpr ik. - - Definition code_of_syscall (name: string) (vs: list eventval) (v: eventval) (ik: info_kind) := - let argsexpr := (list_eventval_to_list_expr vs) in code_of_external argsexpr ik. - - Definition code_of_call (cp cp': compartment) (id: ident) (vs: list eventval) (ik: info_kind) := - match ik with - | info_call _ sg => - let tys := from_sig_fun_data sg in - Scall None (Evar id (Tfunction (dargs tys) (dret tys) (dcc tys))) (list_eventval_to_list_expr vs) - | _ => Sskip - end. - - Definition code_of_return (cp cp': compartment) (v: eventval) (ik: info_kind) := - match ik with - | info_return _ => - Sreturn (Some (eventval_to_expr v)) - | _ => Sskip - end. + 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_of_return (cp cp': compartment) (v: eventval) (ik: info_kind) := *) - (* match ik with *) - (* | info_return sg => *) - (* Sreturn (Some (eventval_to_expr_return v (sig_res sg))) *) - (* | _ => Sskip *) - (* end. *) + 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_of_ievent (e: ievent): statement := - match e with - | (Event_vload ch id ofs v, ik) => code_of_vload ch id ofs v ik - | (Event_vstore ch id ofs v, ik) => code_of_vstore ch id ofs v ik - | (Event_annot str vs, ik) => code_of_annot str vs ik - | (Event_call cp cp' id vs, ik) => code_of_call cp cp' id vs ik - | (Event_syscall name vs v, ik) => code_of_syscall name vs v ik - | (Event_return cp cp' v, ik) => code_of_return cp cp' v ik - end. (* A while(1)-loop with a big switch inside it *) - (* TODO: needs to distinguish intra/cross syscall *) (* Definition code_of_trace (fds: funs_data) (t: trace) cnt: statement := *) (* Swhile (Econst_int Int.one (Tint I32 Signed noattr)) (switch cnt (map (code_of_event fds) t) (Sreturn None)). *) From 2a6f7367853afd95b1a1ebc72ae2a9e9c9a3982c Mon Sep 17 00:00:00 2001 From: ldj Date: Sun, 13 Aug 2023 20:19:11 +0200 Subject: [PATCH 116/174] WIP --- security/Backtranslation.v | 6 +++++ security/BtInfoAsm.v | 53 +++++++++++++++++++------------------- 2 files changed, 33 insertions(+), 26 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index ebcf9f5a29..4838983130 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -683,6 +683,12 @@ Section Backtranslation. 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. (* A while(1)-loop with a big switch inside it *) (* Definition code_of_trace (fds: funs_data) (t: trace) cnt: statement := *) diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 0e273af2a4..9522fd4f6f 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -65,7 +65,7 @@ Section BUNDLE. (d: mem_delta) . - Definition bundle_trace := list (ident * bundle_event). + Definition bundle_trace := list (ident * compartment * bundle_event). Definition unbundle_ev (be: (bundle_event)): trace := match be with @@ -74,7 +74,7 @@ Section BUNDLE. | (Bundle_builtin tr _ _ _) => tr end. - Definition unbundle (be: (ident * bundle_event)): trace := unbundle_ev (snd be). + Definition unbundle (be: (ident * compartment * bundle_event)): trace := unbundle_ev (snd be). Fixpoint unbundle_trace (btr: bundle_trace) : trace := match btr with @@ -100,7 +100,7 @@ Section BUNDLE. Qed. Inductive istar {genv state : Type} - (step : genv -> state -> (ident * bundle_event) -> state -> Prop) (ge : genv) : + (step : genv -> state -> (ident * compartment * 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), @@ -207,7 +207,8 @@ Section IR. Definition ir_state := option (block * mem * ir_conts)%type. - Variant ir_step (ge: Asm.genv) : ir_state -> (ident * bundle_event) -> ir_state -> Prop := + Variant ir_step (ge: Asm.genv) : + ir_state -> (ident * compartment * bundle_event) -> ir_state -> Prop := | ir_step_cross_call_internal cur m1 ik tr id evargs sg @@ -227,7 +228,7 @@ Section IR. 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 ge (Some (cur, m1, ik)) (id_cur, cp, 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 @@ -250,7 +251,7 @@ Section IR. 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 ge (Some (cur, m1, ik)) (id_cur, cp_cur, Bundle_return tr evretv d) (Some (next, m2, ik_tl)) | ir_step_intra_call_external cur m1 m2 ik tr id evargs sg @@ -272,7 +273,7 @@ Section IR. 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 ge (Some (cur, m1, ik)) (id_cur, cp_cur, Bundle_call tr id evargs sg d) (Some (cur, m2, ik)) | ir_step_builtin cur m1 m2 ik tr ef evargs @@ -288,7 +289,7 @@ Section IR. 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 ge (Some (cur, m1, ik)) (id_cur, cp_cur, Bundle_builtin tr ef evargs d) (Some (cur, m2, ik)) | ir_step_cross_call_external1 (* early cut at call *) cur m1 ik @@ -306,7 +307,7 @@ Section IR. 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 ge (Some (cur, m1, ik)) (id_cur, cp, Bundle_call tr id evargs sg []) None | ir_step_cross_call_external2 (* early cut at call-ext_call *) cur m1 ik @@ -332,7 +333,7 @@ Section IR. 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 ge (Some (cur, m1, ik)) (id_cur, cp, Bundle_call (tr1 ++ tr2) id evargs sg d) None | ir_step_cross_call_external3 (* early cut at call-ext_call *) cur m1 ik @@ -364,7 +365,7 @@ Section IR. 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)). + ir_step ge (Some (cur, m1, ik)) (id_cur, cp, Bundle_call (tr1 ++ tr2 ++ tr3) id evargs sg d) (Some (cur, m2, ik)). End IR. @@ -1238,7 +1239,7 @@ Section PROOF. - (* 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))]). + exists ([(id_cur, Genv.find_comp ge (Vptr cur Ptrofs.zero), 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. @@ -1251,7 +1252,7 @@ Section PROOF. 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 ([(id_cur, Genv.find_comp ge (Vptr cur Ptrofs.zero), 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. @@ -1263,7 +1264,7 @@ Section PROOF. splits; auto. } { destruct ECKO as [_ OBS]. 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 ([(id_cur, Genv.find_comp ge (Vptr cur Ptrofs.zero), 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. @@ -1282,7 +1283,7 @@ Section PROOF. { 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 ([(id_cur, Genv.find_comp ge (Vptr cur Ptrofs.zero), 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. @@ -1293,7 +1294,7 @@ Section PROOF. 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 ([(id_cur, Genv.find_comp ge (Vptr cur Ptrofs.zero), 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. @@ -1410,7 +1411,7 @@ Section PROOF. - (* 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)]). + exists ([(id_cur, (Genv.find_comp ge (Vptr cur Ptrofs.zero)), 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. @@ -1419,7 +1420,7 @@ Section PROOF. 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 ([(id_cur, (Genv.find_comp ge (Vptr cur Ptrofs.zero)), 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. @@ -1430,7 +1431,7 @@ Section PROOF. splits; auto. } { destruct ECKO as [_ OBS]. 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 ([(id_cur, (Genv.find_comp ge (Vptr cur Ptrofs.zero)), 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. @@ -1448,7 +1449,7 @@ Section PROOF. { 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 ([(id_cur, (Genv.find_comp ge (Vptr cur Ptrofs.zero)), 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. @@ -1458,7 +1459,7 @@ Section PROOF. 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 ([(id_cur, (Genv.find_comp ge (Vptr cur Ptrofs.zero)), 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. @@ -1688,7 +1689,7 @@ Section PROOF. } } 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'. + exists ((id_cur, (Genv.find_comp ge (Vptr cur Ptrofs.zero)), 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. @@ -2135,7 +2136,7 @@ Section PROOF. 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. + exists ([(id_cur, comp_of f, 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. } @@ -2180,7 +2181,7 @@ Section PROOF. 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. + { exists ([(id_cur, (Genv.find_comp ge (Vptr cur Ptrofs.zero)), 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. } @@ -2202,7 +2203,7 @@ Section PROOF. 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. + { exists ([(id_cur, (Genv.find_comp ge (Vptr cur Ptrofs.zero)), 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. @@ -2224,7 +2225,7 @@ Section PROOF. } 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. + exists ([(id_cur, (Genv.find_comp ge (Vptr cur Ptrofs.zero)), 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. From 597dd4f93c92132363e52f421e68d26522f0a094 Mon Sep 17 00:00:00 2001 From: ldj Date: Sun, 13 Aug 2023 21:05:24 +0200 Subject: [PATCH 117/174] WIP --- security/Backtranslation.v | 7 ++--- security/BtInfoAsm.v | 53 +++++++++++++++++++------------------- 2 files changed, 30 insertions(+), 30 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 4838983130..48c0ac497c 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -690,9 +690,10 @@ Section Backtranslation. | Bundle_builtin tr ef evargs d => code_bundle_builtin cp tr ef evargs d end. - (* A while(1)-loop with a big switch inside it *) - (* Definition code_of_trace (fds: funs_data) (t: trace) cnt: statement := *) - (* Swhile (Econst_int Int.one (Tint I32 Signed noattr)) (switch cnt (map (code_of_event fds) t) (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 (Econst_int Int.one (Tint I32 Signed noattr)) + (switch cnt (map (fun ib => code_bundle_event cp (snd ib)) tr) (Sreturn None)). End CODE. diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 9522fd4f6f..0e273af2a4 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -65,7 +65,7 @@ Section BUNDLE. (d: mem_delta) . - Definition bundle_trace := list (ident * compartment * bundle_event). + Definition bundle_trace := list (ident * bundle_event). Definition unbundle_ev (be: (bundle_event)): trace := match be with @@ -74,7 +74,7 @@ Section BUNDLE. | (Bundle_builtin tr _ _ _) => tr end. - Definition unbundle (be: (ident * compartment * bundle_event)): trace := unbundle_ev (snd be). + Definition unbundle (be: (ident * bundle_event)): trace := unbundle_ev (snd be). Fixpoint unbundle_trace (btr: bundle_trace) : trace := match btr with @@ -100,7 +100,7 @@ Section BUNDLE. Qed. Inductive istar {genv state : Type} - (step : genv -> state -> (ident * compartment * bundle_event) -> state -> Prop) (ge : genv) : + (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), @@ -207,8 +207,7 @@ Section IR. Definition ir_state := option (block * mem * ir_conts)%type. - Variant ir_step (ge: Asm.genv) : - ir_state -> (ident * compartment * bundle_event) -> ir_state -> Prop := + 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 @@ -228,7 +227,7 @@ Section IR. id_cur (IDCUR: Genv.invert_symbol ge cur = Some id_cur) : - ir_step ge (Some (cur, m1, ik)) (id_cur, cp, Bundle_call tr id evargs sg d) (Some (b, m2, (ir_cont cur) :: ik)) + 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 @@ -251,7 +250,7 @@ Section IR. id_cur (IDCUR: Genv.invert_symbol ge cur = Some id_cur) : - ir_step ge (Some (cur, m1, ik)) (id_cur, cp_cur, Bundle_return tr evretv d) (Some (next, m2, ik_tl)) + 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 @@ -273,7 +272,7 @@ Section IR. id_cur (IDCUR: Genv.invert_symbol ge cur = Some id_cur) : - ir_step ge (Some (cur, m1, ik)) (id_cur, cp_cur, Bundle_call tr id evargs sg d) (Some (cur, m2, ik)) + 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 @@ -289,7 +288,7 @@ Section IR. id_cur (IDCUR: Genv.invert_symbol ge cur = Some id_cur) : - ir_step ge (Some (cur, m1, ik)) (id_cur, cp_cur, Bundle_builtin tr ef evargs d) (Some (cur, m2, ik)) + 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 @@ -307,7 +306,7 @@ Section IR. id_cur (IDCUR: Genv.invert_symbol ge cur = Some id_cur) : - ir_step ge (Some (cur, m1, ik)) (id_cur, cp, Bundle_call tr id evargs sg []) None + 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 @@ -333,7 +332,7 @@ Section IR. id_cur (IDCUR: Genv.invert_symbol ge cur = Some id_cur) : - ir_step ge (Some (cur, m1, ik)) (id_cur, cp, Bundle_call (tr1 ++ tr2) id evargs sg d) None + 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 @@ -365,7 +364,7 @@ Section IR. id_cur (IDCUR: Genv.invert_symbol ge cur = Some id_cur) : - ir_step ge (Some (cur, m1, ik)) (id_cur, cp, Bundle_call (tr1 ++ tr2 ++ tr3) id evargs sg d) (Some (cur, m2, ik)). + ir_step ge (Some (cur, m1, ik)) (id_cur, Bundle_call (tr1 ++ tr2 ++ tr3) id evargs sg d) (Some (cur, m2, ik)). End IR. @@ -1239,7 +1238,7 @@ Section PROOF. - (* extcall is unknown *) exploit match_mem_external_call_establish1; eauto. unfold match_mem; splits; eauto. intros. des. - exists ([(id_cur, Genv.find_comp ge (Vptr cur Ptrofs.zero), Bundle_call t ef_id (vals_to_eventvals ge args) (ef_sig ef0) (d))]). + 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. @@ -1252,7 +1251,7 @@ Section PROOF. 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, Genv.find_comp ge (Vptr cur Ptrofs.zero), 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 ([(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. @@ -1264,7 +1263,7 @@ Section PROOF. splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. - exists ([(id_cur, Genv.find_comp ge (Vptr cur Ptrofs.zero), 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 ([(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. @@ -1283,7 +1282,7 @@ Section PROOF. { 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, Genv.find_comp ge (Vptr cur Ptrofs.zero), Bundle_call [Event_annot text args0] ef_id (vals_to_eventvals ge args) {| sig_args := targs; sig_res := Tvoid; sig_cc := cc_default |} ([]))]). + 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. @@ -1294,7 +1293,7 @@ Section PROOF. splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. - exists ([(id_cur, Genv.find_comp ge (Vptr cur Ptrofs.zero), Bundle_call [Event_annot text [arg]] ef_id [val_to_eventval ge res] {| sig_args := [targ]; sig_res := targ; sig_cc := cc_default |} ([]))]). + 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. @@ -1411,7 +1410,7 @@ Section PROOF. - (* extcall is unknown *) exploit match_mem_external_call_establish1; eauto. unfold match_mem; splits; eauto. intros. des. - exists ([(id_cur, (Genv.find_comp ge (Vptr cur Ptrofs.zero)), Bundle_builtin t1 ef (vals_to_eventvals ge vargs) d)]). + 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. @@ -1420,7 +1419,7 @@ Section PROOF. 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, (Genv.find_comp ge (Vptr cur Ptrofs.zero)), Bundle_builtin [Event_vload chunk id ofs0 ev] (EF_vload cp chunk) [EVptr_global id ofs0] [])]). + 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. @@ -1431,7 +1430,7 @@ Section PROOF. splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. - exists ([(id_cur, (Genv.find_comp ge (Vptr cur Ptrofs.zero)), Bundle_builtin [Event_vstore chunk id ofs0 ev] (EF_vstore cp chunk) [EVptr_global id ofs0; ev] [])]). + 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. @@ -1449,7 +1448,7 @@ Section PROOF. { 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, (Genv.find_comp ge (Vptr cur Ptrofs.zero)), Bundle_builtin [Event_annot text args] (EF_annot cp kind text targs) (vals_to_eventvals ge vargs) [])]). + 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. @@ -1459,7 +1458,7 @@ Section PROOF. splits; auto. } { destruct ECKO as [_ OBS]. inv EXTCALL; simpl in *; clarify. - exists ([(id_cur, (Genv.find_comp ge (Vptr cur Ptrofs.zero)), Bundle_builtin [Event_annot text [arg]] (EF_annot_val cp kind text targ) [val_to_eventval ge vres] [])]). + 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. @@ -1689,7 +1688,7 @@ Section PROOF. } } intros (btr & ist' & UTR & ISTAR'). - exists ((id_cur, (Genv.find_comp ge (Vptr cur Ptrofs.zero)), 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'. + 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. @@ -2136,7 +2135,7 @@ Section PROOF. eapply CHECKPUB; eauto. apply Senv.invert_find_symbol; auto. } intros (m_i' & APPD & MEMINJ). - exists ([(id_cur, comp_of f, 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. + 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. } @@ -2181,7 +2180,7 @@ Section PROOF. intros (cp & cp' & sg & FACT1 & FACT2 & FACT3 & FACT4 & FACT5 & FACT6 & FACT7 & FACT8). subst. inv STAR; ss. (* subcase 1 *) - { exists ([(id_cur, (Genv.find_comp ge (Vptr cur Ptrofs.zero)), 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. + { 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. } @@ -2203,7 +2202,7 @@ Section PROOF. destruct x0 as (d' & m1 & m2 & res' & EFACT1 & EFACT2 & EFACT3 & (k2 & d2 & m_a02 & MM)). inv STAR. (* subcase 2 *) - { exists ([(id_cur, (Genv.find_comp ge (Vptr cur Ptrofs.zero)), 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. + { 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. @@ -2225,7 +2224,7 @@ Section PROOF. } eapply asm_to_ir_compose. 2:{ instantiate (1:=t3). rewrite app_comm_cons. setoid_rewrite app_assoc. eauto. } - exists ([(id_cur, (Genv.find_comp ge (Vptr cur Ptrofs.zero)), 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. + 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. From 8ceb05822e0c37849b6dddda1653bd1413bd95b1 Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 14 Aug 2023 17:38:00 +0200 Subject: [PATCH 118/174] WIP --- security/Backtranslation.v | 219 +++++++++++++++++++++++++++++-------- 1 file changed, 173 insertions(+), 46 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 48c0ac497c..1de070d231 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -187,8 +187,13 @@ Section Backtranslation. Definition not_in_env (e: env) id := e ! id = None. + (* Definition wf_env (e: env) := *) + (* forall id, if (Senv.public_symbol ge id) then not_in_env e id else True. *) Definition wf_env (e: env) := - forall id, if (Senv.public_symbol ge id) then not_in_env e id else True. + 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 @@ -469,27 +474,7 @@ Section Backtranslation. Section CODE. (** converting *informative* trace to code **) - Variable ge: Clight.genv. - - Lemma ptr_of_id_ofs_eval - id ofs e b cp le m - (GE1: wf_env ge e) - (GE2: Senv.public_symbol ge id) - (GE3: 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. + Variable ge: Senv.t. Definition code_mem_delta_storev cp0 (d: mem_delta_storev): statement := let '(ch, ptr, v, cp) := d in @@ -518,23 +503,70 @@ Section Backtranslation. 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. + + (* A while(1)-loop with big if-then-elses inside it *) + Definition code_bundle_trace cp (cnt: ident) (tr: bundle_trace): statement := + Swhile (Econst_int Int.one (Tint I32 Signed noattr)) + (switch cnt (map (fun ib => code_bundle_event cp (snd ib)) tr) (Sreturn None)). + + End CODE. + + + Section CODEPROOFS. + + Variable ge: Clight.genv. + + Lemma ptr_of_id_ofs_eval + 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 cp k d sn : - code_mem_delta cp (k :: d) sn = - Ssequence (code_mem_delta_kind cp k) (code_mem_delta cp 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 cp d1 d2 sn : - code_mem_delta cp (d1 ++ d2) sn = (code_mem_delta cp d1 (code_mem_delta cp 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 ch ty v e (WF: wf_chunk_val_b ch v) @@ -605,7 +637,7 @@ Section Backtranslation. (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 (comp_of f) d) k e le m) + 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. @@ -645,7 +677,7 @@ Section Backtranslation. cp d (NWF: wf_mem_delta_storev_b ge cp d = false) : - code_mem_delta_storev cp d = Sskip. + 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 @@ -654,7 +686,7 @@ Section Backtranslation. (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 (comp_of f) d snext) k e le 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. @@ -672,30 +704,125 @@ Section Backtranslation. all: take_step; take_step; eapply IHd; eauto. Qed. + End CODEPROOFS. + + + 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) (tr: bundle_trace) (a_f: Asm.function): function := + let a_sg := Asm.fn_sig a_f in + let targs := list_typ_to_list_type a_sg.(sig_args) 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 + (combine params targs) + [] + [] + (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 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 gen_globvar (gv: globvar unit): globvar type := + mkglobvar Tvoid gv.(gvar_comp) gv.(gvar_init) gv.(gvar_readonly) gv.(gvar_volatile). - 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 default_globvar: globvar type := + mkglobvar Tvoid default_compartment [] false false. - 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 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 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 + 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. + Admitted. + + (* Generate fresh counter ids with definitions for each global definitions *) + Definition gen_counter_defs m (gds: list (ident * globdef Asm.fundef unit)): PTree.t (ident * globdef Clight.fundef type) := + fold_left (fun pt '(id, gd) => PTree.set id (Pos.add id m, gen_counter (comp_of gd)) pt) gds (@PTree.empty _). + + (* Generate fresh parameter ids for each function *) + Definition gen_params (m: positive) (gds: list (ident * globdef Asm.fundef unit)): PTree.t (list ident). + Admitted. + + Definition gen_progdef (ge: Senv.t) (tr: bundle_trace) a_gd (ocnt: option (ident * globdef Clight.fundef type)) (oparams: option (list ident)): globdef Clight.fundef type := + match ocnt, oparams with + | Some (cnt, _), Some params => gen_globdef ge cnt params tr a_gd + | _, _ => Gvar default_globvar end. - (* A while(1)-loop with big if-then-elses inside it *) - Definition code_bundle_trace cp (cnt: ident) (tr: bundle_trace): statement := - Swhile (Econst_int Int.one (Tint I32 Signed noattr)) - (switch cnt (map (fun ib => code_bundle_event cp (snd ib)) tr) (Sreturn None)). + 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 tr gd (cnts ! id) (params ! id))) gds) ++ cnt_defs. - End CODE. + 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 GENPROOFS. + + Definition wf_keys {A} (l: list (ident * A)) := list_norepet (map fst l). + + Lemma next_id_lt + A (l: list (ident * A)) + id a + (IN: In (id, a) l) + : + Pos.lt id (next_id l). + Proof. + Admitted. + + 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. + Admitted. + + Lemma gen_params_lt + m agds + id ps + (GET: (gen_params m agds) ! id = Some ps) + p + (IN: In p ps) + : + Pos.lt m p. + Proof. + Admitted. + + End GENPROOFS. Section CODEPROP. From 2f99503d3fa7cfcbea460f943f8aa9e305a1a3fe Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 15 Aug 2023 13:59:03 +0200 Subject: [PATCH 119/174] WIP --- security/Backtranslation.v | 76 ++++++++++++++++++++++++++++++++++++-- 1 file changed, 73 insertions(+), 3 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 1de070d231..8a07a7aaf6 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -135,7 +135,7 @@ Section Backtranslation. now apply G; lia. Qed. - Let nat64 n := Int64.repr (Z.of_nat n). + Definition nat64 n := Int64.repr (Z.of_nat n). Lemma switch_spec (ge: genv) (cnt: ident) f (e: env) le m b k @@ -757,7 +757,7 @@ Section Backtranslation. Definition gen_counter_defs m (gds: list (ident * globdef Asm.fundef unit)): PTree.t (ident * globdef Clight.fundef type) := fold_left (fun pt '(id, gd) => PTree.set id (Pos.add id m, gen_counter (comp_of gd)) pt) gds (@PTree.empty _). - (* Generate fresh parameter ids for each function *) + (* Generate fresh parameter ids for each function --- parameter ids for different functions are allowed to be duplicated *) Definition gen_params (m: positive) (gds: list (ident * globdef Asm.fundef unit)): PTree.t (list ident). Admitted. @@ -767,13 +767,15 @@ Section Backtranslation. | _, _ => 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 tr gd (cnts ! id) (params ! id))) gds) ++ cnt_defs. + (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 @@ -825,6 +827,74 @@ Section Backtranslation. End GENPROOFS. + 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_symbols_inject + ge1 ge2 + (MSYMB: match_symbs ge1 ge2) + : + symbols_inject (meminj_public ge1) ge1 ge2. + Proof. + Admitted. + + End GENV. + + + Section COUNTERS. + + Definition cnt_ids := PTree.t ident. + + Definition wf_env_cnt_ids (e: env) (cnts: cnt_ids) := forall id cnt, cnts ! id = Some cnt -> e ! cnt = None. + + Definition wf_counter (ge: Senv.t) (m: mem) cp (n: nat) (cnt: ident): Prop := + 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: Clight.genv) (m: mem) (tr: bundle_trace) (cnts: cnt_ids) := + forall id (f: function) cnt, (Genv.find_symbol ge id = Some b) -> (Genv.find_funct_ptr ge b = Some (Internal f)) -> + (cnts ! id = Some cnt) -> + +switch_spec: + forall (ge : genv) (cnt : ident) (f : function) (e : env) (le : temp_env) (m : mem) (b : block) (k : cont) (ss : list statement) (s : statement) (ss' : list statement) (s_else : statement), + Z.of_nat (Datatypes.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 (Datatypes.length ss))) -> + exists m' : mem, + Mem.storev Mint64 m (Vptr b Ptrofs.zero) (Vlong (Int64.add (nat64 (Datatypes.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') + + + End COUNTERS. + +(* Genv.initmem_inject: forall [F V : Type] {CF : has_comp F} (p : AST.program F V) [m : mem], Genv.init_mem p = Some m -> Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m *) +(* Genv.alloc_globals_neutral: *) +(* forall [F V : Type] {CF : has_comp F} (ge : Genv.t F V) [thr : block], *) +(* (forall (id : ident) (b : block), Genv.find_symbol ge id = Some b -> Plt b thr) -> *) +(* forall (gl : list (ident * globdef F V)) (m m' : mem), Genv.alloc_globals ge m gl = Some m' -> Mem.inject_neutral thr m -> Ple (Mem.nextblock m') thr -> Mem.inject_neutral thr m' *) + + Section INV. + + Definition match_senv (ge ge': Senv.t) := match_symbs 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). + (* /\ (public_rev_perm m_i m_c). *) + + + End INV. + + Section CODEPROP. Let cgenv := Genv.t fundef type. From 9ca567002709b0ac897764c59c04b4de63f36789 Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 15 Aug 2023 16:56:01 +0200 Subject: [PATCH 120/174] WIP --- security/Backtranslation.v | 149 +++++++++++++++++++++++++++++++------ 1 file changed, 127 insertions(+), 22 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 8a07a7aaf6..1f74ecedf1 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -835,6 +835,66 @@ Section Backtranslation. 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_symbols_inject ge1 ge2 (MSYMB: match_symbs ge1 ge2) @@ -846,6 +906,62 @@ Section Backtranslation. 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. + + End PROOF. + + Section COUNTERS. Definition cnt_ids := PTree.t ident. @@ -858,31 +974,15 @@ Section Backtranslation. (Mem.loadv Mint64 m (Vptr b Ptrofs.zero) (Some cp) = Some (Vlong (nat64 n))). Definition wf_counters (ge: Clight.genv) (m: mem) (tr: bundle_trace) (cnts: cnt_ids) := - forall id (f: function) cnt, (Genv.find_symbol ge id = Some b) -> (Genv.find_funct_ptr ge b = Some (Internal f)) -> - (cnts ! id = Some cnt) -> - -switch_spec: - forall (ge : genv) (cnt : ident) (f : function) (e : env) (le : temp_env) (m : mem) (b : block) (k : cont) (ss : list statement) (s : statement) (ss' : list statement) (s_else : statement), - Z.of_nat (Datatypes.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 (Datatypes.length ss))) -> - exists m' : mem, - Mem.storev Mint64 m (Vptr b Ptrofs.zero) (Vlong (Int64.add (nat64 (Datatypes.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') - + forall id b (f: function) cnt, + (Genv.find_symbol ge id = Some b) -> (Genv.find_funct_ptr ge b = Some (Internal f)) -> + (cnts ! id = Some cnt) -> + wf_counter ge m (comp_of f) (length (get_id_tr tr id)) cnt. End COUNTERS. -(* Genv.initmem_inject: forall [F V : Type] {CF : has_comp F} (p : AST.program F V) [m : mem], Genv.init_mem p = Some m -> Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m *) -(* Genv.alloc_globals_neutral: *) -(* forall [F V : Type] {CF : has_comp F} (ge : Genv.t F V) [thr : block], *) -(* (forall (id : ident) (b : block), Genv.find_symbol ge id = Some b -> Plt b thr) -> *) -(* forall (gl : list (ident * globdef F V)) (m m' : mem), Genv.alloc_globals ge m gl = Some m' -> Mem.inject_neutral thr m -> Ple (Mem.nextblock m') thr -> Mem.inject_neutral thr m' *) - Section INV. + Section MATCH. Definition match_senv (ge ge': Senv.t) := match_symbs ge ge'. @@ -892,8 +992,13 @@ switch_spec: (* /\ (public_rev_perm m_i m_c). *) - End INV. + End MATCH. +(* Genv.initmem_inject: forall [F V : Type] {CF : has_comp F} (p : AST.program F V) [m : mem], Genv.init_mem p = Some m -> Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m *) +(* Genv.alloc_globals_neutral: *) +(* forall [F V : Type] {CF : has_comp F} (ge : Genv.t F V) [thr : block], *) +(* (forall (id : ident) (b : block), Genv.find_symbol ge id = Some b -> Plt b thr) -> *) +(* forall (gl : list (ident * globdef F V)) (m m' : mem), Genv.alloc_globals ge m gl = Some m' -> Mem.inject_neutral thr m -> Ple (Mem.nextblock m') thr -> Mem.inject_neutral thr m' *) Section CODEPROP. From ca40ff4fe672edd135753ed2b5f0b5b01b0fabbc Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 15 Aug 2023 18:29:35 +0200 Subject: [PATCH 121/174] WIP --- security/Backtranslation.v | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 1f74ecedf1..880f11f2be 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -991,6 +991,14 @@ Section Backtranslation. (Mem.inject k m_i m_c) /\ (inject_incr j k) /\ (meminj_not_alloc j m_i). (* /\ (public_rev_perm m_i m_c). *) + Definition match_cur (ge: Clight.genv) (cur: block) (f: function): Prop := + Genv.find_funct_ptr ge cur = Some (Internal f). + + + +Inductive state : Type := + State : function -> statement -> cont -> env -> temp_env -> mem -> state | Callstate : fundef -> list val -> cont -> mem -> state | Returnstate : val -> cont -> mem -> rettype -> compartment -> state. +ir_state = option (block * mem * ir_conts) End MATCH. From a4a405b5a1678ab995f06677e11a8ab242055ed6 Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 16 Aug 2023 14:29:14 +0200 Subject: [PATCH 122/174] WIP --- security/Backtranslation.v | 97 ++++++++++++++++++++++++++++++++------ 1 file changed, 82 insertions(+), 15 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 880f11f2be..64c4159939 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -520,10 +520,14 @@ Section Backtranslation. | 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 (Econst_int Int.one (Tint I32 Signed noattr)) - (switch cnt (map (fun ib => code_bundle_event cp (snd ib)) tr) (Sreturn None)). + Swhile one_expr (switch_bundle_events cnt cp tr). End CODE. @@ -704,6 +708,28 @@ Section Backtranslation. all: take_step; take_step; eapply IHd; eauto. Qed. + Lemma code_bundle_trace_spec + 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. @@ -748,7 +774,6 @@ Section Backtranslation. 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. Admitted. @@ -962,7 +987,7 @@ Section Backtranslation. End PROOF. - Section COUNTERS. + Section INVS. Definition cnt_ids := PTree.t ident. @@ -979,10 +1004,6 @@ Section Backtranslation. (cnts ! id = Some cnt) -> wf_counter ge m (comp_of f) (length (get_id_tr tr id)) cnt. - End COUNTERS. - - - Section MATCH. Definition match_senv (ge ge': Senv.t) := match_symbs ge ge'. @@ -991,16 +1012,62 @@ Section Backtranslation. (Mem.inject k m_i m_c) /\ (inject_incr j k) /\ (meminj_not_alloc j m_i). (* /\ (public_rev_perm m_i m_c). *) - Definition match_cur (ge: Clight.genv) (cur: block) (f: function): Prop := - Genv.find_funct_ptr ge cur = Some (Internal f). + Definition match_fun (ge: Clight.genv) (cur: block) (f: function) (id: ident): Prop := + Genv.find_funct_ptr ge cur = Some (Internal f) /\ Genv.invert_symbol ge cur = Some id. + + 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: match_fun ge b f 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 wf_env_unique_blocks (e: env) := + forall id1 id2 b1 ty1 b2 ty2, e ! id1 = Some (b1, ty1) -> e ! id2 = Some (b2, ty2) -> id1 <> id2 -> b1 <> b2. - + Definition wf_env_mem (ge: Clight.genv) cp (e: env) (m: mem) := + let eranges := blocks_of_env ge e in + Forall (fun '(b, lo, hi) => Mem.range_perm m b lo hi Cur Freeable /\ Mem.can_access_block m b (Some cp)) eranges. + + Lemma wf_env_conds_implies_free_list + ge cp e m + (WFEUB: wf_env_unique_blocks e) + (WFEM: wf_env_mem ge cp e m) + : + exists m', Mem.free_list m (blocks_of_env ge e) cp = Some m'. + Proof. + Admitted. + + + Inductive wf_c_cont (ge: Clight.genv) (m: mem): (cont) -> Prop := + | wf_c_cont_nil + : + wf_c_cont ge m Kstop + | wf_c_cont_cons + ck + f e le s1 s2 ck' + (WFEUB: wf_env_unique_blocks e) + (WFEM: wf_env_mem ge (comp_of f) e m) + (CK: ck = Kcall None f e le (Kloop1 s1 s2 ck')) + (IND: wf_c_cont ge m ck') + : + wf_c_cont ge m ck. -Inductive state : Type := - State : function -> statement -> cont -> env -> temp_env -> mem -> state | Callstate : fundef -> list val -> cont -> mem -> state | Returnstate : val -> cont -> mem -> rettype -> compartment -> state. -ir_state = option (block * mem * ir_conts) + (* TODO *) - End MATCH. + End INVS. (* Genv.initmem_inject: forall [F V : Type] {CF : has_comp F} (p : AST.program F V) [m : mem], Genv.init_mem p = Some m -> Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m *) (* Genv.alloc_globals_neutral: *) From c37bd5066933b24c499403a5acea9e5c76a7fb23 Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 16 Aug 2023 17:31:46 +0200 Subject: [PATCH 123/174] WIP --- security/Backtranslation.v | 149 ++++++++++++++++++++++++++++++------- security/MemoryDelta.v | 1 + 2 files changed, 124 insertions(+), 26 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 64c4159939..49a13b4498 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -991,6 +991,7 @@ Section Backtranslation. Definition cnt_ids := PTree.t ident. + (* well-formedness *) Definition wf_env_cnt_ids (e: env) (cnts: cnt_ids) := forall id cnt, cnts ! id = Some cnt -> e ! cnt = None. Definition wf_counter (ge: Senv.t) (m: mem) cp (n: nat) (cnt: ident): Prop := @@ -1004,6 +1005,55 @@ Section Backtranslation. (cnts ! id = Some cnt) -> wf_counter ge m (comp_of f) (length (get_id_tr tr id)) cnt. + Definition wf_env_unique_blocks (e: env) := + forall id1 id2 b1 ty1 b2 ty2, e ! id1 = Some (b1, ty1) -> e ! id2 = Some (b2, ty2) -> id1 <> id2 -> b1 <> b2. + + Definition wf_env_mem (ge: Clight.genv) cp (e: env) (m: mem) := + let eranges := blocks_of_env ge e in + Forall (fun '(b, lo, hi) => Mem.range_perm m b lo hi Cur Freeable /\ Mem.can_access_block m b (Some cp)) eranges. + + Lemma wf_env_conds_implies_free_list + ge cp e m + (WFEUB: wf_env_unique_blocks e) + (WFEM: wf_env_mem ge cp e m) + : + exists m', Mem.free_list m (blocks_of_env ge e) cp = Some m'. + Proof. + Admitted. + + Inductive wf_c_cont (ge: Clight.genv) (m: mem): (cont) -> Prop := + | wf_c_cont_nil + : + wf_c_cont ge m Kstop + | wf_c_cont_cons + ck + f e le s1 s2 ck' + (WFEUB: wf_env_unique_blocks e) + (WFEM: wf_env_mem ge (comp_of f) e m) + (CK: ck = Kcall None f e le (Kloop1 s1 s2 ck')) + (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 := + match cnts ! id with + | Some cnt => stmt = code_bundle_trace ge cp cnt (get_id_tr tr id) + | _ => False + end. + + Definition wf_c_state (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 m_c tr cnts /\ wf_c_cont ge m_c k_c /\ wf_c_stmt ge (comp_of f) cnts id ttr stmt /\ + (wf_env ge e /\ wf_env_unique_blocks e /\ wf_env_mem ge (comp_of f) e m_c) + | _ => False + end. + + + Definition wf_c_genv (ge: Clight.genv) := + forall b f, (Genv.find_funct_ptr ge b = Some (Internal f)) -> + (list_norepet (var_names (fn_params f) ++ var_names (fn_vars f))). + Definition match_senv (ge ge': Senv.t) := match_symbs ge ge'. @@ -1034,40 +1084,87 @@ Section Backtranslation. : match_cont ge tr cnts ck ik. - Definition wf_env_unique_blocks (e: env) := - forall id1 id2 b1 ty1 b2 ty2, e ! id1 = Some (b1, ty1) -> e ! id2 = Some (b2, ty2) -> id1 <> id2 -> b1 <> b2. + Definition match_state (ge_i: Asm.genv) (ge_c: Clight.genv) (k: meminj) tr cnts 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_senv ge_i ge_c) /\ (match_mem ge_i k m_i m_c) /\ (match_fun ge_c cur f id) /\ (match_cont ge_c tr cnts k_c k_i) + | _, _ => False + end. - Definition wf_env_mem (ge: Clight.genv) cp (e: env) (m: mem) := - let eranges := blocks_of_env ge e in - Forall (fun '(b, lo, hi) => Mem.range_perm m b lo hi Cur Freeable /\ Mem.can_access_block m b (Some cp)) eranges. + End INVS. - Lemma wf_env_conds_implies_free_list - ge cp e m - (WFEUB: wf_env_unique_blocks e) - (WFEM: wf_env_mem ge cp e m) - : - exists m', Mem.free_list m (blocks_of_env ge e) cp = Some m'. + + Section PROOF. + + 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 ir_to_clight_step + (ge_i: Asm.genv) (ge_c: Clight.genv) + (WFCG: wf_c_genv ge_c) + cnts ist1 ev ist2 + (STEP: ir_step ge_i ist1 ev ist2) + ttr pretr btr + (TOTAL: ttr = pretr ++ ev :: btr) + cst1 k id + (WFC: wf_c_state ge_c pretr ttr cnts id cst1) + (MS: match_state ge_i ge_c k ttr cnts id ist1 cst1) + : + exists cst2, (star step1 ge_c cst1 (unbundle ev) cst2) /\ + exists id', (wf_c_state ge_c (pretr ++ [ev]) ttr cnts id' cst2) /\ + exists k, (match_state ge_i ge_c k ttr cnts id' ist2 cst2). Proof. + (* TODO *) + Admitted. + Lemma ir_to_clight_aux + (ge_i: Asm.genv) (ge_c: Clight.genv) + (WFCG: wf_c_genv ge_c) + (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 k id + (WFC: wf_c_state ge_c pretr ttr cnts id cst) + (MS: match_state ge_i ge_c k ttr cnts 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. + Qed. - Inductive wf_c_cont (ge: Clight.genv) (m: mem): (cont) -> Prop := - | wf_c_cont_nil + Theorem ir_to_clight + (ge_i: Asm.genv) (ge_c: Clight.genv) + (WFCG: wf_c_genv ge_c) + ist cst + ttr cnts k id + (WFC: wf_c_state ge_c [] ttr cnts id cst) + (MS: match_state ge_i ge_c k ttr cnts id ist cst) + ist' + (STAR: istar (ir_step) ge_i ist ttr ist') : - wf_c_cont ge m Kstop - | wf_c_cont_cons - ck - f e le s1 s2 ck' - (WFEUB: wf_env_unique_blocks e) - (WFEM: wf_env_mem ge (comp_of f) e m) - (CK: ck = Kcall None f e le (Kloop1 s1 s2 ck')) - (IND: wf_c_cont ge m ck') - : - wf_c_cont ge m ck. - - (* TODO *) + exists cst', star step1 ge_c cst (unbundle_trace ttr) cst'. + Proof. eapply ir_to_clight_aux. 4,5,6,7: eauto. all: eauto. econs 1. ss. econs 1. Qed. - End INVS. + End PROOF. (* Genv.initmem_inject: forall [F V : Type] {CF : has_comp F} (p : AST.program F V) [m : mem], Genv.init_mem p = Some m -> Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m *) (* Genv.alloc_globals_neutral: *) diff --git a/security/MemoryDelta.v b/security/MemoryDelta.v index abe009ce17..bc7e2a120c 100644 --- a/security/MemoryDelta.v +++ b/security/MemoryDelta.v @@ -298,6 +298,7 @@ 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 From df9782cbd2aa722bd58fbf5f18afae0a6f6514c4 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 17 Aug 2023 10:50:00 +0200 Subject: [PATCH 124/174] WIP --- security/Backtranslation.v | 164 ++++++++++++++++++++++++++++++------- 1 file changed, 136 insertions(+), 28 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 49a13b4498..8c58069ba9 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -534,10 +534,8 @@ Section Backtranslation. Section CODEPROOFS. - Variable ge: Clight.genv. - Lemma ptr_of_id_ofs_eval - id ofs e b cp le m + (ge: genv) id ofs e b cp le m (GE1: wf_env ge e) (GE2: Senv.find_symbol ge id = Some b) : @@ -556,14 +554,14 @@ Section Backtranslation. Qed. Lemma code_mem_delta_cons - cp k d sn + (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 - cp d1 d2 sn + (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. @@ -572,7 +570,7 @@ Section Backtranslation. Qed. Lemma type_of_chunk_val_to_expr - ch ty v e + (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) @@ -587,7 +585,7 @@ Section Backtranslation. Proof. destruct v; ss; auto. Qed. Lemma sem_cast_chunk_val - m ch ty v e + (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) @@ -610,7 +608,7 @@ Section Backtranslation. end. Lemma chunk_val_to_expr_eval - ch v exp e cp le m + (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) : @@ -625,7 +623,7 @@ Section Backtranslation. Proof. unfold wf_chunk_val_b in WF. des_ifs; ss; eauto. Qed. Lemma wf_chunk_val_chunk_val_to_expr - ch v + (ge: Senv.t) ch v (WF: wf_chunk_val_b ch v) : exists ve, chunk_val_to_expr ge ch v = Some ve. @@ -635,7 +633,7 @@ Section Backtranslation. Qed. Lemma code_mem_delta_storev_correct - f k e le m m' + (ge: genv) f k e le m m' d (WFE: wf_env ge e) (STORE: mem_delta_apply_storev (Some m) d = Some m') @@ -678,13 +676,14 @@ Section Backtranslation. Qed. Lemma wf_mem_delta_storev_false_is_skip - cp d + (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) @@ -709,7 +708,7 @@ Section Backtranslation. Qed. Lemma code_bundle_trace_spec - cp cnt tr + (ge: genv) cp cnt tr f e le m k : star step1 ge @@ -782,10 +781,15 @@ Section Backtranslation. Definition gen_counter_defs m (gds: list (ident * globdef Asm.fundef unit)): PTree.t (ident * globdef Clight.fundef type) := fold_left (fun pt '(id, gd) => PTree.set id (Pos.add id m, gen_counter (comp_of gd)) pt) gds (@PTree.empty _). + Definition params_of := PTree.t (list ident). + (* Generate fresh parameter ids for each function --- parameter ids for different functions are allowed to be duplicated *) - Definition gen_params (m: positive) (gds: list (ident * globdef Asm.fundef unit)): PTree.t (list ident). + Definition gen_params (m: positive) (gds: list (ident * globdef Asm.fundef unit)): params_of. Admitted. + Definition wf_params_of (pars: params_of) := + forall id params, (pars ! id = Some params) -> list_norepet params. + Definition gen_progdef (ge: Senv.t) (tr: bundle_trace) a_gd (ocnt: option (ident * globdef Clight.fundef type)) (oparams: option (list ident)): globdef Clight.fundef type := match ocnt, oparams with | Some (cnt, _), Some params => gen_globdef ge cnt params tr a_gd @@ -849,6 +853,13 @@ Section Backtranslation. Proof. Admitted. + Lemma gen_params_wf + m agds + : + wf_params_of (gen_params m agds). + Proof. + Admitted. + End GENPROOFS. @@ -919,6 +930,81 @@ Section Backtranslation. 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_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. + - unfold code_bundle_call. erewrite match_symbs_code_mem_delta; eauto. + - unfold code_bundle_return. erewrite match_symbs_code_mem_delta; eauto. + - unfold code_bundle_builtin. erewrite match_symbs_code_mem_delta; eauto. + 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_mem_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 @@ -1050,10 +1136,6 @@ Section Backtranslation. end. - Definition wf_c_genv (ge: Clight.genv) := - forall b f, (Genv.find_funct_ptr ge b = Some (Internal f)) -> - (list_norepet (var_names (fn_params f) ++ var_names (fn_vars f))). - Definition match_senv (ge ge': Senv.t) := match_symbs ge ge'. @@ -1065,6 +1147,16 @@ Section Backtranslation. Definition match_fun (ge: Clight.genv) (cur: block) (f: function) (id: ident): Prop := Genv.find_funct_ptr ge cur = Some (Internal f) /\ Genv.invert_symbol ge 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 @@ -1084,10 +1176,12 @@ Section Backtranslation. : match_cont ge tr cnts ck ik. - Definition match_state (ge_i: Asm.genv) (ge_c: Clight.genv) (k: meminj) tr cnts id (ist: ir_state) (cst: Clight.state) := + 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_senv ge_i ge_c) /\ (match_mem ge_i k m_i m_c) /\ (match_fun ge_c cur f id) /\ (match_cont ge_c tr cnts k_c k_i) + (match_senv ge_i ge_c) /\ (match_mem ge_i k m_i m_c) /\ + (match_fun 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) | _, _ => False end. @@ -1114,9 +1208,20 @@ Section Backtranslation. (MS: match_state ge_i ge_c k ttr cnts id ist1 cst1) : exists cst2, (star step1 ge_c cst1 (unbundle ev) cst2) /\ - exists id', (wf_c_state ge_c (pretr ++ [ev]) ttr cnts id' cst2) /\ - exists k, (match_state ge_i ge_c k ttr cnts id' ist2 cst2). + ((exists id', (wf_c_state ge_c (pretr ++ [ev]) ttr cnts id' cst2) /\ + exists k, (match_state ge_i ge_c k ttr cnts 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 (WFC0 & WFC1 & WFC2 & WFC3 & WFC4 & WFC5). + 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). + move STEP after WFC5. inv STEP. + + - exists (State + + + (* TODO *) Admitted. @@ -1142,13 +1247,16 @@ Section Backtranslation. { 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. + - 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 From f090138240f318912aed3050a080666eaeb7be46 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 17 Aug 2023 17:28:18 +0200 Subject: [PATCH 125/174] WIP --- security/Backtranslation.v | 145 ++++++++++++++++++++++++++++++++----- 1 file changed, 127 insertions(+), 18 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 8c58069ba9..978e3feb01 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -860,6 +860,19 @@ Section Backtranslation. Proof. Admitted. + + 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. + End GENPROOFS. @@ -976,6 +989,30 @@ Section Backtranslation. 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) @@ -984,9 +1021,7 @@ Section Backtranslation. code_bundle_event ge1 cp = code_bundle_event ge2 cp. Proof. extensionalities be. unfold code_bundle_event. des_ifs. - - unfold code_bundle_call. erewrite match_symbs_code_mem_delta; eauto. - - unfold code_bundle_return. erewrite match_symbs_code_mem_delta; eauto. - - unfold code_bundle_builtin. erewrite match_symbs_code_mem_delta; eauto. + 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 @@ -1086,10 +1121,12 @@ Section Backtranslation. (Mem.loadv Mint64 m (Vptr b Ptrofs.zero) (Some cp) = Some (Vlong (nat64 n))). Definition wf_counters (ge: Clight.genv) (m: mem) (tr: bundle_trace) (cnts: cnt_ids) := - forall id b (f: function) cnt, + forall id b (f: function), (Genv.find_symbol ge id = Some b) -> (Genv.find_funct_ptr ge b = Some (Internal f)) -> - (cnts ! id = Some cnt) -> - wf_counter ge m (comp_of f) (length (get_id_tr tr id)) cnt. + (exists cnt, (cnts ! id = Some cnt) /\ (wf_counter ge m (comp_of f) (length (get_id_tr tr id)) cnt)). + + Definition wf_counters_find (ge: Clight.genv) (cnts: cnt_ids) := + forall id cnt, cnts ! id = Some cnt -> exists b_cnt, Genv.find_symbol ge cnt = Some b_cnt. Definition wf_env_unique_blocks (e: env) := forall id1 id2 b1 ty1 b2 ty2, e ! id1 = Some (b1, ty1) -> e ! id2 = Some (b2, ty2) -> id1 <> id2 -> b1 <> b2. @@ -1130,7 +1167,8 @@ Section Backtranslation. Definition wf_c_state (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 m_c tr cnts /\ wf_c_cont ge m_c k_c /\ wf_c_stmt ge (comp_of f) cnts id ttr stmt /\ + wf_counters ge m_c tr cnts /\ wf_counters_find ge cnts /\ + wf_c_cont ge m_c k_c /\ wf_c_stmt ge (comp_of f) cnts id ttr stmt /\ (wf_env ge e /\ wf_env_unique_blocks e /\ wf_env_mem ge (comp_of f) e m_c) | _ => False end. @@ -1198,45 +1236,116 @@ Section Backtranslation. Lemma ir_to_clight_step (ge_i: Asm.genv) (ge_c: Clight.genv) - (WFCG: wf_c_genv ge_c) - cnts ist1 ev ist2 + 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_c pretr ttr cnts id cst1) - (MS: match_state ge_i ge_c k ttr cnts id ist1 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_c (pretr ++ [ev]) ttr cnts id' cst2) /\ - exists k, (match_state ge_i ge_c k ttr cnts id' ist2 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 (WFC0 & WFC1 & WFC2 & WFC3 & WFC4 & WFC5). + destruct WFC as (WFC0 & WFC1 & WFC2 & WFC3 & WFC4 & WFC5 & WFC6). 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). + destruct MS as (MS0 & MS1 & MS2 & MS3 & MS4). move STEP after WFC5. inv STEP. - - exists (State + - assert (id = id_cur). + { unfold match_fun in MS2. des. destruct MS0 as (MSENV0 & MSENV1 & MSENV2). + apply Genv.invert_find_symbol in IDCUR. apply MSENV1 in IDCUR. apply Senv.find_invert_symbol in IDCUR. setoid_rewrite MS5 in IDCUR. clarify. + } + subst id. + rename f_next into fi_next. exploit MS3. + { unfold Genv.find_funct in FINDF. des_ifs. unfold Genv.find_funct_ptr in FINDF. des_ifs. eapply Heq. } + { 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. + set (fn_body f_next) as stmt_next. + assert (FIND_CUR_C: Genv.find_symbol ge_c id_cur = Some cur). + { destruct MS2 as (MFUN0 & MFUN1). apply Genv.invert_find_symbol; eauto. } + assert (FIND_FUN_C: Genv.find_funct_ptr ge_c cur = Some (Internal f)). + { destruct MS2 as (MFUN0 & MFUN1). auto. } + exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. } + destruct WF_CNT_CUR as (cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & 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 WFC4. specialize (WFC4 cnt_cur). des_ifs. eapply WFC4. } + 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'). + { admit. } + des. + 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). + { admit. } + 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). + { admit. } + 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 (WFC_NEXT: wf_c_state ge_c (pretr ++ [(id_cur, Bundle_call tr id_next evargs (fn_sig fi_next) d)]) ttr cnts id_next cst2). + { admit. } + 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). + { admit. } + exists cst2. split. + 2:{ left. exists id_next. split. apply WFC_NEXT. eexists. eapply MS_NEXT. } + + unfold wf_c_stmt in WFC3. rewrite CNTS_CUR in WFC3. 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. auto. } + 2: ss. + unfold unbundle. simpl. rename b into next. econs 2. + { eapply step_call. + (* TODO *) + + + econs. + + + 2: econs 1. 2: setoid_rewrite app_nil_r; auto. + eapply step_call. - (* TODO *) Admitted. Lemma ir_to_clight_aux (ge_i: Asm.genv) (ge_c: Clight.genv) - (WFCG: wf_c_genv ge_c) (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 k id + ttr cnts pars k id + (BOUND: Z.of_nat (Datatypes.length ttr) < Int64.modulus) (WFC: wf_c_state ge_c pretr ttr cnts id cst) - (MS: match_state ge_i ge_c k ttr cnts id ist 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') From 3b45437533ce022102c67e16d619166ad16b3fc5 Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 28 Aug 2023 18:16:44 +0200 Subject: [PATCH 126/174] WIP --- security/Backtranslation.v | 552 +++++++++++++++++++------------------ 1 file changed, 287 insertions(+), 265 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 978e3feb01..b4e82cb1ea 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -788,7 +788,11 @@ Section Backtranslation. Admitted. Definition wf_params_of (pars: params_of) := - forall id params, (pars ! id = Some params) -> list_norepet params. + (forall id params, (pars ! id = Some params) -> list_norepet 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) -> + (Forall2 (fun _ _ => True) params (sig_args (Asm.funsig f))). Definition gen_progdef (ge: Senv.t) (tr: bundle_trace) a_gd (ocnt: option (ident * globdef Clight.fundef type)) (oparams: option (list ident)): globdef Clight.fundef type := match ocnt, oparams with @@ -860,6 +864,13 @@ Section Backtranslation. Proof. Admitted. + (* Lemma gen_params_wf_sig *) + (* m agds *) + (* : *) + (* wf_params_of_sig (gen_params m agds). *) + (* Proof. *) + (* Admitted. *) + Lemma get_id_tr_cons id be tr @@ -1182,8 +1193,8 @@ Section Backtranslation. (Mem.inject k m_i m_c) /\ (inject_incr j k) /\ (meminj_not_alloc j m_i). (* /\ (public_rev_perm m_i m_c). *) - Definition match_fun (ge: Clight.genv) (cur: block) (f: function) (id: ident): Prop := - Genv.find_funct_ptr ge cur = Some (Internal f) /\ Genv.invert_symbol ge cur = Some id. + Definition match_cur_fun (ge: Asm.genv) (cur: block) f (id: ident): Prop := + Genv.find_funct_ptr ge cur = Some (AST.Internal f) /\ Genv.invert_symbol ge 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, @@ -1195,7 +1206,7 @@ Section Backtranslation. | _, _ => False end. - Inductive match_cont (ge: Clight.genv) (tr: bundle_trace) (cnts: cnt_ids) : (cont) -> (ir_conts) -> Prop := + Inductive match_cont (ge: Asm.genv) (tr: bundle_trace) (cnts: cnt_ids) : (cont) -> (ir_conts) -> Prop := | match_cont_nil ck ik (CK: ck = Kstop) @@ -1206,7 +1217,7 @@ Section Backtranslation. ck ik f e le cnt id ck' b ik' - (FUN: match_fun ge b f id) + (FUN: match_cur_fun ge b f 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') @@ -1214,12 +1225,15 @@ Section Backtranslation. : match_cont ge tr cnts ck ik. + Definition match_params pars ge_i := (wf_params_of pars) /\ (wf_params_of_sig pars ge_i). + 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_senv ge_i ge_c) /\ (match_mem ge_i k m_i m_c) /\ (match_fun 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_cont ge_c tr cnts k_c k_i) /\ + (match_params pars ge_i) | _, _ => False end. @@ -1228,174 +1242,9 @@ Section Backtranslation. Section PROOF. - 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 ir_to_clight_step - (ge_i: Asm.genv) (ge_c: Clight.genv) - 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_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_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 (WFC0 & WFC1 & WFC2 & WFC3 & WFC4 & WFC5 & WFC6). - 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). - move STEP after WFC5. inv STEP. - - - assert (id = id_cur). - { unfold match_fun in MS2. des. destruct MS0 as (MSENV0 & MSENV1 & MSENV2). - apply Genv.invert_find_symbol in IDCUR. apply MSENV1 in IDCUR. apply Senv.find_invert_symbol in IDCUR. setoid_rewrite MS5 in IDCUR. clarify. - } - subst id. - rename f_next into fi_next. exploit MS3. - { unfold Genv.find_funct in FINDF. des_ifs. unfold Genv.find_funct_ptr in FINDF. des_ifs. eapply Heq. } - { 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. - set (fn_body f_next) as stmt_next. - assert (FIND_CUR_C: Genv.find_symbol ge_c id_cur = Some cur). - { destruct MS2 as (MFUN0 & MFUN1). apply Genv.invert_find_symbol; eauto. } - assert (FIND_FUN_C: Genv.find_funct_ptr ge_c cur = Some (Internal f)). - { destruct MS2 as (MFUN0 & MFUN1). auto. } - exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. } - destruct WF_CNT_CUR as (cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & 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 WFC4. specialize (WFC4 cnt_cur). des_ifs. eapply WFC4. } - 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'). - { admit. } - des. - 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). - { admit. } - 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). - { admit. } - 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 (WFC_NEXT: wf_c_state ge_c (pretr ++ [(id_cur, Bundle_call tr id_next evargs (fn_sig fi_next) d)]) ttr cnts id_next cst2). - { admit. } - 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). - { admit. } - exists cst2. split. - 2:{ left. exists id_next. split. apply WFC_NEXT. eexists. eapply MS_NEXT. } - - unfold wf_c_stmt in WFC3. rewrite CNTS_CUR in WFC3. 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. auto. } - 2: ss. - unfold unbundle. simpl. rename b into next. econs 2. - { eapply step_call. - (* TODO *) - - - econs. - - - 2: econs 1. 2: setoid_rewrite app_nil_r; auto. - eapply step_call. - - - (* TODO *) - - Admitted. - - Lemma ir_to_clight_aux - (ge_i: Asm.genv) (ge_c: Clight.genv) - (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_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) - (WFCG: wf_c_genv ge_c) - ist cst - ttr cnts k id - (WFC: wf_c_state ge_c [] ttr cnts id cst) - (MS: match_state ge_i ge_c k ttr cnts 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. 4,5,6,7: eauto. all: eauto. econs 1. ss. econs 1. Qed. - - End PROOF. - -(* Genv.initmem_inject: forall [F V : Type] {CF : has_comp F} (p : AST.program F V) [m : mem], Genv.init_mem p = Some m -> Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m *) -(* Genv.alloc_globals_neutral: *) -(* forall [F V : Type] {CF : has_comp F} (ge : Genv.t F V) [thr : block], *) -(* (forall (id : ident) (b : block), Genv.find_symbol ge id = Some b -> Plt b thr) -> *) -(* forall (gl : list (ident * globdef F V)) (m m' : mem), Genv.alloc_globals ge m gl = Some m' -> Mem.inject_neutral thr m -> Ple (Mem.nextblock m') thr -> Mem.inject_neutral thr m' *) - - Section CODEPROP. - - Let cgenv := Genv.t fundef type. - (* Properties *) Lemma eventval_match_transl - F V (ge: Genv.t F V) + (ge: Senv.t) ev ty v (EM: eventval_match ge ev ty v) : @@ -1406,87 +1255,48 @@ Section Backtranslation. Qed. Lemma eventval_match_eventval_to_val - F V (ge: Genv.t F V) + (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_match_wf_eventval_ge - F V (ge: Genv.t F V) - ev ty v - (EM: eventval_match ge ev ty v) - : - wf_eventval_ge ge ev. - Proof. inversion EM; subst; simpl; eauto. Qed. - Lemma eventval_list_match_transl - F V (ge: Genv.t F V) + (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. + Proof. induction EM; simpl. constructor. constructor; auto. eapply eventval_match_transl; eauto. Qed. Lemma eventval_list_match_transl_val - F V (ge: Genv.t F V) + (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. + Proof. induction EM; simpl. constructor. constructor; auto. erewrite eventval_match_eventval_to_val; eauto. Qed. Lemma typ_type_typ - F V (ge: Genv.t F V) + (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 ptr_of_id_ofs_eval *) - (* id ofs e (ge: genv) b cp le m *) - (* (GE1: wf_env e id) *) - (* (GE2: Genv.find_symbol ge id = Some b) *) - (* : *) - (* eval_expr ge e cp le m (ptr_of_id_ofs id ofs) (Vptr b ofs). *) - (* Proof. *) - (* 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 eventval_to_expr_val_eval - (ge: genv) en cp temp m ev - (WFENV: wf_eventval_env en ev) - (WFGE: wf_eventval_ge ge ev) + (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. - destruct WFGE as [b WFGE]. - rewrite WFGE. unfold ptr_of_id_ofs. destruct Archi.ptr64 eqn:ARCH. - - econstructor; try econstructor. eapply eval_Evar_global; eauto. - simpl. simpl_expr. rewrite Ptrofs.mul_commut, Ptrofs.mul_one. rewrite Ptrofs.add_zero_l. - rewrite Ptrofs.of_int64_to_int64; auto. - - econstructor; try econstructor. eapply eval_Evar_global; eauto. - 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. + 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: cgenv) v ty vv m + (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. @@ -1497,11 +1307,14 @@ Section Backtranslation. 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: 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). @@ -1511,16 +1324,15 @@ Section Backtranslation. revert tys Heqtys2 Heqvs2. induction EMS; intros; subst; simpl in *. { destruct tys; simpl in *. constructor. congruence. } inversion Heqvs2; clear Heqvs2; subst; simpl in *. - inversion WFENV; clear WFENV; subst. 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 eventval_match_wf_eventval_ge; eauto. *) eapply sem_cast_eventval_match; eauto. Qed. Lemma eventval_match_eventval_to_type - F V (ge: Genv.t F V) + (ge: Senv.t) ev ty v (EM: eventval_match ge ev ty v) : @@ -1528,7 +1340,7 @@ Section Backtranslation. Proof. inversion EM; subst; simpl; auto. Qed. Lemma list_eventval_match_eventval_to_type - F V (ge: Genv.t F V) + (ge: Senv.t) evs tys vs (ESM: eventval_list_match ge evs tys vs) : @@ -1560,7 +1372,7 @@ Section Backtranslation. Qed. Lemma eventval_match_proj_rettype - F V (ge: Genv.t F V) + (ge: Senv.t) ev ty v (EM: eventval_match ge ev ty v) : @@ -1570,30 +1382,30 @@ Section Backtranslation. 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 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 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: cgenv) + (ge: genv) m ev ty v (EM: eventval_match ge ev ty v) : @@ -1606,20 +1418,20 @@ Section Backtranslation. - 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 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 @@ -1630,7 +1442,7 @@ Section Backtranslation. Qed. Lemma sem_cast_proj_rettype - (ge: cgenv) evres rty res m + (ge: genv) evres rty res m (EVM: eventval_match ge evres (proj_rettype rty) res) : Cop.sem_cast (eventval_to_val ge evres) @@ -1667,7 +1479,217 @@ Section Backtranslation. } Qed. - End CODEPROP. + Lemma type_of_params_eq + ids ts + (PARSIGS : Forall2 (fun (_ : ident) (_ : typ) => True) ids ts) + : + type_of_params (combine ids (list_typ_to_list_type ts)) = list_typ_to_typelist ts. + Proof. induction PARSIGS; ss. f_equal. auto. Qed. + + + Lemma match_senv_eventval_match + (ge0 ge1: Senv.t) + (MS: match_senv 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_senv 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 ir_to_clight_step + (ge_i: Asm.genv) (ge_c: Clight.genv) + 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_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_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 (WFC0 & WFC1 & WFC2 & WFC3 & WFC4 & WFC5 & WFC6). + 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). + move STEP after WFC5. inv STEP. + + - assert (id = id_cur). + { unfold match_fun in MS2. des. destruct MS0 as (MSENV0 & MSENV1 & MSENV2). + apply Genv.invert_find_symbol in IDCUR. apply MSENV1 in IDCUR. apply Senv.find_invert_symbol in IDCUR. setoid_rewrite MS6 in IDCUR. clarify. + } + subst id. + rename f_next into fi_next. exploit MS3. + { unfold Genv.find_funct in FINDF. des_ifs. unfold Genv.find_funct_ptr in FINDF. des_ifs. eapply Heq. } + { 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. + set (fn_body f_next) as stmt_next. + assert (FIND_CUR_C: Genv.find_symbol ge_c id_cur = Some cur). + { destruct MS2 as (MFUN0 & MFUN1). apply Genv.invert_find_symbol; eauto. } + assert (FIND_FUN_C: Genv.find_funct_ptr ge_c cur = Some (Internal f)). + { destruct MS2 as (MFUN0 & MFUN1). auto. } + exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. } + destruct WF_CNT_CUR as (cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). + assert (PARSIGS: Forall2 (fun _ _ => True) params_next (sig_args (fn_sig fi_next))). + { destruct MS5 as (MPARS0 & MPARS1). ss. rewrite pred_dec_true in FINDF; auto. exploit MPARS1. 3: eauto. 2: eauto. all: eauto. } + + hexploit switch_spec. + { subst ttr. rewrite CUR_TR in BOUND2. rewrite map_app in BOUND2. ss. eapply BOUND2. } + { unfold wf_env in WFC4. specialize (WFC4 cnt_cur). des_ifs. eapply WFC4. } + 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'). + { admit. } + des. + 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). + { admit. } + 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). + { admit. } + 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 (WFC_NEXT: wf_c_state ge_c (pretr ++ [(id_cur, Bundle_call tr id_next evargs (fn_sig fi_next) d)]) ttr cnts id_next cst2). + { admit. } + 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). + { admit. } + exists cst2. split. + 2:{ left. exists id_next. split. apply WFC_NEXT. eexists. eapply MS_NEXT. } + + unfold wf_c_stmt in WFC3. rewrite CNTS_CUR in WFC3. 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. auto. } + 2: ss. + unfold unbundle. simpl. rename b into next. 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). apply MSENV1. auto. } + eapply eval_Evar_global. + - unfold wf_env in WFC4. specialize (WFC4 id_next). rewrite FSN_C in WFC4. apply WFC4. + - 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. } + { 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. } + { + MS0 : match_senv ge_i ge_c + MS2 : match_fun ge_c cur f id_cur + MS3 : match_find_def ge_i ge_c cnts pars ttr + ALLOW : Genv.allowed_call ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) (Vptr next Ptrofs.zero) + IDCUR : Genv.invert_symbol ge_i cur = Some id_cur + Genv.allowed_call ge_c (comp_of f) (Vptr next Ptrofs.zero) + + (* TODO *) + + + econs. + + + 2: econs 1. 2: setoid_rewrite app_nil_r; auto. + eapply step_call. + + + (* TODO *) + + Admitted. + + Lemma ir_to_clight_aux + (ge_i: Asm.genv) (ge_c: Clight.genv) + (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_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) + (WFCG: wf_c_genv ge_c) + ist cst + ttr cnts k id + (WFC: wf_c_state ge_c [] ttr cnts id cst) + (MS: match_state ge_i ge_c k ttr cnts 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. 4,5,6,7: eauto. all: eauto. econs 1. ss. econs 1. Qed. + + End PROOF. + +(* Genv.initmem_inject: forall [F V : Type] {CF : has_comp F} (p : AST.program F V) [m : mem], Genv.init_mem p = Some m -> Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m *) +(* Genv.alloc_globals_neutral: *) +(* forall [F V : Type] {CF : has_comp F} (ge : Genv.t F V) [thr : block], *) +(* (forall (id : ident) (b : block), Genv.find_symbol ge id = Some b -> Plt b thr) -> *) +(* forall (gl : list (ident * globdef F V)) (m m' : mem), Genv.alloc_globals ge m gl = Some m' -> Mem.inject_neutral thr m -> Ple (Mem.nextblock m') thr -> Mem.inject_neutral thr m' *) + Section STEPPROP. From 0569ffdb5993ae6276dfe4f42f2bef51837c82fa Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 29 Aug 2023 16:51:46 +0200 Subject: [PATCH 127/174] WIP --- security/Backtranslation.v | 93 ++++++++++++++++++++++++++------------ 1 file changed, 63 insertions(+), 30 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index b4e82cb1ea..cc52e0e721 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -736,16 +736,16 @@ Section Backtranslation. 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) (tr: bundle_trace) (a_f: Asm.function): function := + 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 targs := list_typ_to_list_type a_sg.(sig_args) in + (* let targs := list_typ_to_list_type a_sg.(sig_args) 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 - (combine params targs) + params [] [] (code_bundle_trace ge cp cnt tr). @@ -781,20 +781,23 @@ Section Backtranslation. Definition gen_counter_defs m (gds: list (ident * globdef Asm.fundef unit)): PTree.t (ident * globdef Clight.fundef type) := fold_left (fun pt '(id, gd) => PTree.set id (Pos.add id m, gen_counter (comp_of gd)) pt) gds (@PTree.empty _). - Definition params_of := PTree.t (list ident). + Definition params_of := PTree.t (list (ident * type)). (* Generate fresh parameter ids for each function --- parameter ids for different functions are allowed to be duplicated *) Definition gen_params (m: positive) (gds: list (ident * globdef Asm.fundef unit)): params_of. Admitted. Definition wf_params_of (pars: params_of) := - (forall id params, (pars ! id = Some params) -> list_norepet params). + (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) -> - (Forall2 (fun _ _ => True) params (sig_args (Asm.funsig f))). + (list_typ_to_list_type (sig_args (funsig f)) = map snd params). + (* Definition wf_params_of_sig (pars: params_of) (ge: 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) -> *) + (* forall tyargs tyres cconv, (type_of_fundef f = Tfunction tyargs tyres cconv) -> (type_of_params params = tyargs). *) - Definition gen_progdef (ge: Senv.t) (tr: bundle_trace) a_gd (ocnt: option (ident * globdef Clight.fundef type)) (oparams: option (list ident)): globdef Clight.fundef type := + 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 @@ -850,8 +853,8 @@ Section Backtranslation. m agds id ps (GET: (gen_params m agds) ! id = Some ps) - p - (IN: In p ps) + p t + (IN: In (p, t) ps) : Pos.lt m p. Proof. @@ -1124,7 +1127,7 @@ Section Backtranslation. Definition cnt_ids := PTree.t ident. (* well-formedness *) - Definition wf_env_cnt_ids (e: env) (cnts: cnt_ids) := forall id cnt, cnts ! id = Some cnt -> e ! cnt = None. + (* Definition wf_env_cnt_ids (e: env) (cnts: cnt_ids) := forall id cnt, cnts ! id = Some cnt -> e ! cnt = None. *) Definition wf_counter (ge: Senv.t) (m: mem) cp (n: nat) (cnt: ident): Prop := exists b, (Senv.find_symbol ge cnt = Some b) /\ @@ -1135,9 +1138,14 @@ Section Backtranslation. forall id b (f: function), (Genv.find_symbol ge id = Some b) -> (Genv.find_funct_ptr ge b = Some (Internal f)) -> (exists cnt, (cnts ! id = Some cnt) /\ (wf_counter ge m (comp_of f) (length (get_id_tr tr id)) cnt)). + (* Definition wf_counters (ge: Clight.genv) (m: mem) (tr: bundle_trace) (cnts: cnt_ids) := *) + (* forall id b (f: function) cnt, *) + (* (Genv.find_symbol ge id = Some b) -> (Genv.find_funct_ptr ge b = Some (Internal f)) -> *) + (* (cnts ! id = Some cnt) -> *) + (* (wf_counter ge m (comp_of f) (length (get_id_tr tr id)) cnt). *) - Definition wf_counters_find (ge: Clight.genv) (cnts: cnt_ids) := - forall id cnt, cnts ! id = Some cnt -> exists b_cnt, Genv.find_symbol ge cnt = Some b_cnt. + (* Definition wf_counters_find (ge: Senv.t) (cnts: cnt_ids) := *) + (* forall id cnt, cnts ! id = Some cnt -> exists b_cnt, Senv.find_symbol ge cnt = Some b_cnt. *) Definition wf_env_unique_blocks (e: env) := forall id1 id2 b1 ty1 b2 ty2, e ! id1 = Some (b1, ty1) -> e ! id2 = Some (b2, ty2) -> id1 <> id2 -> b1 <> b2. @@ -1170,19 +1178,28 @@ Section Backtranslation. wf_c_cont ge m ck. Definition wf_c_stmt (ge: Senv.t) cp cnts id tr stmt := - match cnts ! id with - | Some cnt => stmt = code_bundle_trace ge cp cnt (get_id_tr tr id) - | _ => False - end. + forall cnt, (cnts ! id = Some cnt) -> stmt = code_bundle_trace ge cp cnt (get_id_tr tr id). + (* match cnts ! id with *) + (* | Some cnt => stmt = code_bundle_trace ge cp cnt (get_id_tr tr id) *) + (* | _ => False *) + (* end. *) Definition wf_c_state (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 m_c tr cnts /\ wf_counters_find ge cnts /\ + wf_counters ge m_c tr cnts /\ wf_c_cont ge m_c k_c /\ wf_c_stmt ge (comp_of f) cnts id ttr stmt /\ (wf_env ge e /\ wf_env_unique_blocks e /\ wf_env_mem ge (comp_of f) e m_c) | _ => False end. + (* Definition wf_c_state (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 m_c tr cnts /\ wf_counters_find ge cnts /\ *) + (* wf_c_cont ge m_c k_c /\ wf_c_stmt ge (comp_of f) cnts id ttr stmt /\ *) + (* (wf_env ge e /\ wf_env_unique_blocks e /\ wf_env_mem ge (comp_of f) e m_c) *) + (* | _ => False *) + (* end. *) @@ -1193,8 +1210,10 @@ Section Backtranslation. (Mem.inject k m_i m_c) /\ (inject_incr j k) /\ (meminj_not_alloc j m_i). (* /\ (public_rev_perm m_i m_c). *) - Definition match_cur_fun (ge: Asm.genv) (cur: block) f (id: ident): Prop := - Genv.find_funct_ptr ge cur = Some (AST.Internal f) /\ Genv.invert_symbol ge cur = Some id. + 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, @@ -1206,7 +1225,7 @@ Section Backtranslation. | _, _ => False end. - Inductive match_cont (ge: Asm.genv) (tr: bundle_trace) (cnts: cnt_ids) : (cont) -> (ir_conts) -> Prop := + Inductive match_cont (ge: Clight.genv) (tr: bundle_trace) (cnts: cnt_ids) : (cont) -> (ir_conts) -> Prop := | match_cont_nil ck ik (CK: ck = Kstop) @@ -1217,7 +1236,9 @@ Section Backtranslation. ck ik f e le cnt id ck' b ik' - (FUN: match_cur_fun ge b f id) + (* (FUN: match_cur_fun ge b f id) *) + (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') @@ -1231,7 +1252,7 @@ Section Backtranslation. match ist, cst with | Some (cur, m_i, k_i), State f _ k_c e le m_c => (match_senv ge_i ge_c) /\ (match_mem ge_i k m_i m_c) /\ - (match_fun ge_c cur f id) /\ (match_find_def ge_i ge_c cnts pars tr) /\ + (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_i) | _, _ => False @@ -1528,27 +1549,39 @@ Section Backtranslation. \/ (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 (WFC0 & WFC1 & WFC2 & WFC3 & WFC4 & WFC5 & WFC6). + destruct WFC as (WFC0 & WFC1 & WFC2 & WFC3 & WFC4 & WFC5). 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). move STEP after WFC5. inv STEP. - assert (id = id_cur). - { unfold match_fun in MS2. des. destruct MS0 as (MSENV0 & MSENV1 & MSENV2). - apply Genv.invert_find_symbol in IDCUR. apply MSENV1 in IDCUR. apply Senv.find_invert_symbol in IDCUR. setoid_rewrite MS6 in IDCUR. clarify. - } + { unfold match_cur_fun in MS2. des. rewrite MS7 in IDCUR. clarify. } + (* destruct MS0 as (MSENV0 & MSENV1 & MSENV2). *) + (* apply Genv.invert_find_symbol in IDCUR. apply Senv.find_invert_symbol in IDCUR. setoid_rewrite MS6 in IDCUR. clarify. *) + (* } *) subst id. rename f_next into fi_next. exploit MS3. - { unfold Genv.find_funct in FINDF. des_ifs. unfold Genv.find_funct_ptr in FINDF. des_ifs. eapply Heq. } + + Set Nested Proofs Allowed. + (* MOVE *) + Lemma ffp_find_def + F V (ge: Genv.t F V) + b fd + (FFP: Genv.find_funct_ptr ge b = Some fd) + : + Genv.find_def ge b = Some (Gfun fd). + Proof. unfold Genv.find_funct_ptr in FFP. des_ifs. Qed. + + { eapply ffp_find_def. 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. + 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 MS2 as (MFUN0 & MFUN1). apply Genv.invert_find_symbol; eauto. } + { destruct MS0 as (MSENV0 & MSENV1 & MSENV2). 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)). - { destruct MS2 as (MFUN0 & MFUN1). auto. } + { (* TODO *) destruct MS2 as (MFUN0 & MFUN1). auto. } exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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)). From 72810ed8a8b101d0846d5f4084e139cc32db15b6 Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 29 Aug 2023 16:55:33 +0200 Subject: [PATCH 128/174] WIP --- security/Backtranslation.v | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index cc52e0e721..57dc0648e9 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1581,7 +1581,8 @@ Section Backtranslation. assert (FIND_CUR_C: Genv.find_symbol ge_c id_cur = Some cur). { destruct MS0 as (MSENV0 & MSENV1 & MSENV2). 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)). - { (* TODO *) destruct MS2 as (MFUN0 & MFUN1). auto. } + { destruct MS2 as (MFUN0 & MFUN1). auto. } + (* TODO *) exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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)). From 2fcbdd94f1a07b68087d19b8a2c7d33f943d0881 Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 4 Sep 2023 18:40:23 +0900 Subject: [PATCH 129/174] WIP --- security/Backtranslation.v | 198 ++++++++++++++++++++++++++++--------- 1 file changed, 151 insertions(+), 47 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 57dc0648e9..f1459da54e 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1203,7 +1203,11 @@ Section Backtranslation. - Definition match_senv (ge ge': Senv.t) := match_symbs ge ge'. + Definition eq_policy (ge1: Asm.genv) (ge2: genv) := + Genv.genv_policy ge1 = Genv.genv_policy ge2. + + 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 @@ -1251,7 +1255,7 @@ Section Backtranslation. 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_senv ge_i ge_c) /\ (match_mem ge_i k m_i 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_i) @@ -1501,16 +1505,19 @@ Section Backtranslation. Qed. Lemma type_of_params_eq - ids ts - (PARSIGS : Forall2 (fun (_ : ident) (_ : typ) => True) ids ts) + params ts + (PARSIGS : list_typ_to_list_type ts = map snd params) : - type_of_params (combine ids (list_typ_to_list_type ts)) = list_typ_to_typelist ts. - Proof. induction PARSIGS; ss. f_equal. auto. Qed. - + 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_senv ge0 ge1) + (MS: match_symbs ge0 ge1) ev ty v (EM: eventval_match ge0 ev ty v) : @@ -1519,7 +1526,7 @@ Section Backtranslation. Lemma match_senv_eventval_list_match (ge0 ge1: Senv.t) - (MS: match_senv ge0 ge1) + (MS: match_symbs ge0 ge1) evs tys vs (EM: eventval_list_match ge0 evs tys vs) : @@ -1532,6 +1539,7 @@ Section Backtranslation. unbundle_trace (tr1 ++ tr2) = (unbundle_trace tr1) ++ (unbundle_trace tr2). Proof. induction tr1; ss. rewrite <- app_assoc. f_equal. auto. Qed. + Lemma ir_to_clight_step (ge_i: Asm.genv) (ge_c: Clight.genv) cnts pars ist1 ev ist2 @@ -1548,6 +1556,9 @@ Section Backtranslation. exists k, (match_state ge_i ge_c k ttr cnts pars id' ist2 cst2)) \/ (ist2 = None)). Proof. + (* REMOVE *) + Set Nested Proofs Allowed. + unfold wf_c_state in WFC. des_ifs. rename s into stmt, k into k_c, m into m_c. destruct WFC as (WFC0 & WFC1 & WFC2 & WFC3 & WFC4 & WFC5). unfold match_state in MS. des_ifs. rename i into k_i, b into cur, m into m_i. @@ -1562,40 +1573,30 @@ Section Backtranslation. subst id. rename f_next into fi_next. exploit MS3. - Set Nested Proofs Allowed. - (* MOVE *) - Lemma ffp_find_def - F V (ge: Genv.t F V) - b fd - (FFP: Genv.find_funct_ptr ge b = Some fd) - : - Genv.find_def ge b = Some (Gfun fd). - Proof. unfold Genv.find_funct_ptr in FFP. des_ifs. Qed. - - { eapply ffp_find_def. erewrite <- Genv.find_funct_find_funct_ptr. eapply FINDF. } + { 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. assert (FIND_CUR_C: Genv.find_symbol ge_c id_cur = Some cur). - { destruct MS0 as (MSENV0 & MSENV1 & MSENV2). apply Genv.invert_find_symbol in IDCUR. apply MSENV1 in IDCUR. auto. } + { 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)). { destruct MS2 as (MFUN0 & MFUN1). auto. } - (* TODO *) + exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. } + { rewrite map_length. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } destruct WF_CNT_CUR as (cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). - assert (PARSIGS: Forall2 (fun _ _ => True) params_next (sig_args (fn_sig fi_next))). - { destruct MS5 as (MPARS0 & MPARS1). ss. rewrite pred_dec_true in FINDF; auto. exploit MPARS1. 3: eauto. 2: eauto. all: eauto. } + 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 switch_spec. { subst ttr. rewrite CUR_TR in BOUND2. rewrite map_app in BOUND2. ss. eapply BOUND2. } - { unfold wf_env in WFC4. specialize (WFC4 cnt_cur). des_ifs. eapply WFC4. } + { 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). @@ -1623,47 +1624,150 @@ Section Backtranslation. exists cst2. split. 2:{ left. exists id_next. split. apply WFC_NEXT. eexists. eapply MS_NEXT. } - unfold wf_c_stmt in WFC3. rewrite CNTS_CUR in WFC3. subst stmt. + 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. 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. econs 2. - { eapply step_call. ss. + { + (* MOVE *) + 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. + + (* MOVE *) + 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. + + eapply step_call. ss. { econs. assert (FSN_C: Senv.find_symbol ge_c id_next = Some next). - { destruct MS0 as (MSENV0 & MSENV1 & MSENV2). apply MSENV1. auto. } + { destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). apply MSENV1. auto. } eapply eval_Evar_global. - - unfold wf_env in WFC4. specialize (WFC4 id_next). rewrite FSN_C in WFC4. apply WFC4. + - 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. } + { 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. } - { - MS0 : match_senv ge_i ge_c - MS2 : match_fun ge_c cur f id_cur - MS3 : match_find_def ge_i ge_c cnts pars ttr - ALLOW : Genv.allowed_call ge_i (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)) (Vptr next Ptrofs.zero) - IDCUR : Genv.invert_symbol ge_i cur = Some id_cur - Genv.allowed_call ge_c (comp_of f) (Vptr next Ptrofs.zero) - - (* TODO *) - - - econs. - + { 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). + rewrite CNTS_CUR in CNT_CUR0. clarify. rename cnt_cur0 into cnt_cur. + replace + (comp_of (gen_function ge_i cnt_cur params_cur (get_id_tr ttr id_cur) f_i_cur)) + with + (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)). + 2:{ unfold Genv.find_comp. setoid_rewrite FINDF_I_CUR. ss. } + destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). + 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. + replace (list_eventval_to_list_val ge_c evargs) with vargs. + 2:{ destruct MS0 as (MSENV & MGENV). inv TR. + + (* MOVE *) + 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. + + symmetry. eapply eventval_list_match_list_eventval_to_list_val. + + (* MOVE *) + 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. + + (* MOVE *) + 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. + + eapply match_symbs_eventval_list_match; eauto. + } + apply NPTR. unfold crossing_comp. + + (* MOVE *) + Lemma type_of_call_eq + + + + destruct ( + + + + + + + + + + + TODO - 2: econs 1. 2: setoid_rewrite app_nil_r; auto. - eapply step_call. (* TODO *) From 1222542823c1ce694be1688ebc1c288ff221d52b Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 4 Sep 2023 22:08:07 +0900 Subject: [PATCH 130/174] WIP --- security/Backtranslation.v | 15 ++------------- 1 file changed, 2 insertions(+), 13 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index f1459da54e..cace7a6e49 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1750,23 +1750,12 @@ Section Backtranslation. } apply NPTR. unfold crossing_comp. + TODO + (* MOVE *) Lemma type_of_call_eq - - destruct ( - - - - - - - - - - - TODO From aa46319a3d76ded524b6fd4da3a6c6ee913b93c5 Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 5 Sep 2023 18:25:19 +0900 Subject: [PATCH 131/174] WIP --- security/Backtranslation.v | 244 +++++++++++++++++++++---------------- 1 file changed, 136 insertions(+), 108 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index cace7a6e49..25700c4d48 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1539,6 +1539,78 @@ Section Backtranslation. unbundle_trace (tr1 ++ tr2) = (unbundle_trace tr1) ++ (unbundle_trace tr2). Proof. induction tr1; ss. rewrite <- app_assoc. f_equal. auto. Qed. + 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 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 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 ir_to_clight_step (ge_i: Asm.genv) (ge_c: Clight.genv) @@ -1567,9 +1639,6 @@ Section Backtranslation. - assert (id = id_cur). { unfold match_cur_fun in MS2. des. rewrite MS7 in IDCUR. clarify. } - (* destruct MS0 as (MSENV0 & MSENV1 & MSENV2). *) - (* apply Genv.invert_find_symbol in IDCUR. apply Senv.find_invert_symbol in IDCUR. setoid_rewrite MS6 in IDCUR. clarify. *) - (* } *) subst id. rename f_next into fi_next. exploit MS3. @@ -1594,6 +1663,18 @@ Section Backtranslation. 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. } + 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). + rewrite CNTS_CUR in CNT_CUR0. inversion CNT_CUR0. subst cnt_cur0. clear CNT_CUR0. + (* set (f := (gen_function ge_i cnt_cur params_cur (get_id_tr ttr id_cur) f_i_cur)) in *. *) + + (* assert (CP_CUR: *) + (* (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))). *) + 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. } + 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. } @@ -1603,8 +1684,22 @@ Section Backtranslation. 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'). - { admit. } + 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')). + { (* After counter update --- need that counters are not private *) + + (* 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_inject2. *) + (* apply MINJ. apply INJINCR. apply NALLOC. apply DELTA. apply PUB. *) + (* intros (m_c' & DELTA' & INJ'). exists m_c'. splits; auto. *) + (* rewrite CP_CUR. *) + + + + (* TODO *) + + admit. } des. 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). { admit. } @@ -1633,53 +1728,20 @@ Section Backtranslation. 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. - unfold unbundle. simpl. rename b into next. econs 2. - { - (* MOVE *) - 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. - - (* MOVE *) - 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. - - eapply step_call. ss. + 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. @@ -1694,66 +1756,32 @@ Section Backtranslation. 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 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). - rewrite CNTS_CUR in CNT_CUR0. clarify. rename cnt_cur0 into cnt_cur. - replace - (comp_of (gen_function ge_i cnt_cur params_cur (get_id_tr ttr id_cur) f_i_cur)) - with - (Genv.find_comp ge_i (Vptr cur Ptrofs.zero)). - 2:{ unfold Genv.find_comp. setoid_rewrite FINDF_I_CUR. ss. } - destruct MS0 as ((MSENV0 & MSENV1 & MSENV2) & MGENV). + { 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. - replace (list_eventval_to_list_val ge_c evargs) with vargs. - 2:{ destruct MS0 as (MSENV & MGENV). inv TR. - - (* MOVE *) - 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. - - symmetry. eapply eventval_list_match_list_eventval_to_list_val. - - (* MOVE *) - 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. - - (* MOVE *) - 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. - - eapply match_symbs_eventval_list_match; eauto. - } - apply NPTR. unfold crossing_comp. - - TODO - - (* MOVE *) - Lemma type_of_call_eq + 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. + + - From 2dad7c0b18891b093e8b89a2ead42dc42260bb49 Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 6 Sep 2023 17:11:37 +0900 Subject: [PATCH 132/174] WIP --- security/Backtranslation.v | 83 ++++++++++++++++++++++++++++++++------ security/MemoryDelta.v | 51 ++++++++++++++++++++++- 2 files changed, 120 insertions(+), 14 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 25700c4d48..7ba27b5c21 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1130,9 +1130,10 @@ Section Backtranslation. (* Definition wf_env_cnt_ids (e: env) (cnts: cnt_ids) := forall id cnt, cnts ! id = Some cnt -> e ! cnt = None. *) Definition wf_counter (ge: Senv.t) (m: mem) cp (n: nat) (cnt: ident): Prop := - 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))). + (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: Clight.genv) (m: mem) (tr: bundle_trace) (cnts: cnt_ids) := forall id b (f: function), @@ -1265,6 +1266,57 @@ Section Backtranslation. End INVS. + (* Section MEM. *) + + (* Import Mem. *) + + (* Lemma store_unmapped_inj_inv : *) + (* forall f chunk m1 b1 ofs v1 cp n m2, *) + (* Mem.mem_inj f m1 m2 -> *) + (* Mem.store chunk m2 b1 ofs v1 cp = Some n -> *) + (* (forall b ofs, f b <> Some (b1, ofs)) -> *) + (* Mem.mem_inj f m1 n. *) + (* Proof. *) + (* intros. constructor. *) + (* (* perm *) *) + (* - intros. eapply perm_store_1. eapply H0. eapply mi_perm; eauto with mem. *) + (* (* own *) *) + (* - intros. rewrite <- store_can_access_block_inj. 2: eauto. eapply mi_own; eauto. *) + (* (* align *) *) + (* - intros. eapply mi_align with (ofs := ofs0) (p := p); eauto. *) + (* (* mem_contents *) *) + (* - intros. rewrite (store_mem_contents _ _ _ _ _ _ _ H0). *) + (* rewrite PMap.gso. eapply mi_memval; eauto with mem. *) + (* intros EQ; subst. eapply H1. eauto. *) + (* Qed. *) + + (* Lemma store_unmapped_inject_inv : *) + (* forall f chunk m1 b1 ofs v1 cp n m2, *) + (* inject f m1 m2 -> *) + (* store chunk m2 b1 ofs v1 cp = Some n -> *) + (* (forall b ofs, f b <> Some (b1, ofs)) -> *) + (* inject f m1 n. *) + (* Proof. *) + (* intros. inversion H. *) + (* constructor. *) + (* (* inj *) *) + (* - eapply store_unmapped_inj_inv; eauto. *) + (* (* freeblocks *) *) + (* - eauto with mem. *) + (* (* mappedblocks *) *) + (* - eauto with mem. *) + (* (* no overlap *) *) + (* - red; intros. eauto with mem. *) + (* (* representable *) *) + (* - intros. eapply mi_representable; try eassumption. *) + (* (* perm inv *) *) + (* - intros. exploit mi_perm_inv0; eauto using perm_store_1. *) + (* intuition eauto using perm_store_1, perm_store_2. *) + (* Qed. *) + + (* End MEM. *) + + Section PROOF. (* Properties *) @@ -1659,7 +1711,7 @@ Section Backtranslation. { 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. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } - destruct WF_CNT_CUR as (cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). + 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. } @@ -1684,17 +1736,22 @@ Section Backtranslation. 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')). - { (* After counter update --- need that counters are not private *) - - (* 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_inject2. *) - (* apply MINJ. apply INJINCR. apply NALLOC. apply DELTA. apply PUB. *) - (* intros (m_c' & DELTA' & INJ'). exists m_c'. splits; auto. *) - (* rewrite CP_CUR. *) - + { 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_preprocess. + apply MINJ. eapply CNT_CUR_STORE. + { + + apply INJINCR. apply NALLOC. apply DELTA. apply PUB. + intros (m_c' & DELTA' & INJ'). exists m_c'. splits; auto. + rewrite CP_CUR. + + + (* After counter update --- need that counters are not private *) + TODO (* TODO *) diff --git a/security/MemoryDelta.v b/security/MemoryDelta.v index bc7e2a120c..54c5e49e1a 100644 --- a/security/MemoryDelta.v +++ b/security/MemoryDelta.v @@ -4,7 +4,6 @@ Require Import AST Linking Smallstep Events Behaviors. Require Import MemoryWeak. Require Import Tactics. - Section AUX. Lemma alloc_left_unmapped_winject_keep: @@ -1092,4 +1091,54 @@ Section PROOFS. 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. + End PROOFS. From af8b1a7f4a5d9f309c5875bcfdd422137097842b Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 6 Sep 2023 18:31:55 +0900 Subject: [PATCH 133/174] WIP --- security/Backtranslation.v | 40 +++++++++++++++++++++++++++++--------- 1 file changed, 31 insertions(+), 9 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 7ba27b5c21..df31ea38bd 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1119,6 +1119,27 @@ Section Backtranslation. eapply FO; eauto. 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. + unfold mem_delta_apply_wf in APPD. rewrite mem_delta_apply_wf_get_wf_mem_delta. + eapply mem_delta_apply_establish_inject_preprocess; 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. + End PROOF. @@ -1741,26 +1762,27 @@ Section Backtranslation. (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_preprocess. + 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. + 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). + { - (* After counter update --- need that counters are not private *) TODO - (* TODO *) admit. } des. - 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). - { admit. } - 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). { admit. } des. From b73bef6c54c6675d747081018be7c09eb13d66d4 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 7 Sep 2023 20:09:17 +0900 Subject: [PATCH 134/174] WIP --- security/Backtranslation.v | 130 ++++++++++++++++++++++++++++++++----- 1 file changed, 115 insertions(+), 15 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index df31ea38bd..2ccbbb98d7 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1683,6 +1683,107 @@ Section Backtranslation. 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', (b' < Mem.nextblock m)%positive -> + forall ch' ofs' p' cp', Mem.valid_access m ch' b' ofs' p' cp' -> + Mem.valid_access m' ch' b' ofs' p' cp'. + Proof. + induction EA; ii; ss. + apply IHEA. + { erewrite Mem.nextblock_alloc; eauto. lia. } + { eapply Mem.valid_access_alloc_other; eauto. } + 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. + { hexploit Mem.alloc_result. eauto. intros; subst. erewrite (Mem.nextblock_alloc _ _ _ _ _ _ H). lia. } + 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 ir_to_clight_step @@ -1740,11 +1841,6 @@ Section Backtranslation. 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. - (* set (f := (gen_function ge_i cnt_cur params_cur (get_id_tr ttr id_cur) f_i_cur)) in *. *) - - (* assert (CP_CUR: *) - (* (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))). *) 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. } @@ -1774,17 +1870,15 @@ Section Backtranslation. } 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). - { - - - TODO - - - - admit. } + { 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). - { admit. } + { 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) @@ -1792,7 +1886,13 @@ Section Backtranslation. e_next le_next m_c_next) as cst2. assert (WFC_NEXT: wf_c_state ge_c (pretr ++ [(id_cur, Bundle_call tr id_next evargs (fn_sig fi_next) d)]) ttr cnts id_next cst2). - { admit. } + { + + + + TODO + + admit. } 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). { admit. } exists cst2. split. From d959c1636368a9286cb75806f435ff8bfe256627 Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 8 Sep 2023 12:44:26 +0900 Subject: [PATCH 135/174] WIP --- security/Backtranslation.v | 83 ++++++++++++++++++++++++++++++++++---- 1 file changed, 76 insertions(+), 7 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 2ccbbb98d7..6a33e8654b 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1753,14 +1753,21 @@ Section Backtranslation. 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 ch' ofs' p' cp', Mem.valid_access m ch' b' ofs' p' cp' -> - Mem.valid_access m' ch' b' ofs' p' cp'. + 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. - induction EA; ii; ss. + 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. - { erewrite Mem.nextblock_alloc; eauto. lia. } { eapply Mem.valid_access_alloc_other; eauto. } + { erewrite Mem.nextblock_alloc; eauto. lia. } Qed. Lemma alloc_variables_forall @@ -1778,7 +1785,6 @@ Section Backtranslation. hexploit alloc_variables_wf_id. apply EA. auto. apply H2. apply PTree.gss. i. esplits; eauto. i. eapply alloc_variables_valid_access. apply EA. - { hexploit Mem.alloc_result. eauto. intros; subst. erewrite (Mem.nextblock_alloc _ _ _ _ _ _ H). lia. } 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. @@ -1886,7 +1892,70 @@ Section Backtranslation. e_next le_next m_c_next) as cst2. assert (WFC_NEXT: wf_c_state 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. + - move WFC0 after le_next. move CNT_CUR_STORE after CUR_SWITCH_STAR. + ii. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. + unfold wf_counter in WFC6. des. unfold wf_counter. splits; auto. + exists b1. splits; auto. + + + + (* MOVE *) + 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. + + eapply bind_parameters_valid_access. eapply ENV_BIND. + eapply alloc_variables_valid_access. eapply ENV_ALLOC. + + (* MOVE *) + 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. + + eapply mem_delta_apply_wf_valid_access. eapply DELTA_C. + eapply Mem.store_valid_access_1. eapply CNT_CUR_STORE. + auto. + + + + From 914c6b5d1c943ecb42c3bf4a69188ee120c88150 Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 8 Sep 2023 16:15:09 +0900 Subject: [PATCH 136/174] WIP --- security/Backtranslation.v | 91 ++++++++++++++++++++++++++++++++++++-- 1 file changed, 87 insertions(+), 4 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 6a33e8654b..4029a2aa53 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1893,7 +1893,7 @@ Section Backtranslation. assert (WFC_NEXT: wf_c_state 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. - - move WFC0 after le_next. move CNT_CUR_STORE after CUR_SWITCH_STAR. + - clear CUR_SWITCH_STAR. move WFC0 after le_next. ii. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. unfold wf_counter in WFC6. des. unfold wf_counter. splits; auto. exists b1. splits; auto. @@ -1953,9 +1953,92 @@ Section Backtranslation. eapply mem_delta_apply_wf_valid_access. eapply DELTA_C. eapply Mem.store_valid_access_1. eapply CNT_CUR_STORE. auto. - + - - + + destruct (Pos.eq_dec id id_cur). + * subst id. clarify. ss. rewrite FIND_CNT_CUR in WFC7. clarify. + + + 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. + + erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. + 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. admit. (*ez*) } + erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. + 2:{ admit. (* same ez *) } + + 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. + + 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. + From 9c1281cb740323043a65b058ba44cae26d9f44e2 Mon Sep 17 00:00:00 2001 From: ldj Date: Sun, 10 Sep 2023 21:22:17 +0900 Subject: [PATCH 137/174] WIP --- security/Backtranslation.v | 298 ++++++++++++++++++++----------------- 1 file changed, 165 insertions(+), 133 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 4029a2aa53..9e6af51b12 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1157,9 +1157,10 @@ Section Backtranslation. (Mem.loadv Mint64 m (Vptr b Ptrofs.zero) (Some cp) = Some (Vlong (nat64 n))). Definition wf_counters (ge: Clight.genv) (m: mem) (tr: bundle_trace) (cnts: cnt_ids) := - forall id b (f: function), - (Genv.find_symbol ge id = Some b) -> (Genv.find_funct_ptr ge b = Some (Internal f)) -> - (exists cnt, (cnts ! id = Some cnt) /\ (wf_counter ge m (comp_of f) (length (get_id_tr tr id)) cnt)). + (forall id0 id1 cnt, (cnts ! id0 = Some cnt) -> (cnts ! id1 = Some cnt) -> (id0 = id1)) /\ + (forall id b (f: function), + (Genv.find_symbol ge id = Some b) -> (Genv.find_funct_ptr ge b = Some (Internal f)) -> + (exists cnt, (cnts ! id = Some cnt) /\ (wf_counter ge m (comp_of f) (length (get_id_tr tr id)) cnt))). (* Definition wf_counters (ge: Clight.genv) (m: mem) (tr: bundle_trace) (cnts: cnt_ids) := *) (* forall id b (f: function) cnt, *) (* (Genv.find_symbol ge id = Some b) -> (Genv.find_funct_ptr ge b = Some (Internal f)) -> *) @@ -1790,6 +1791,139 @@ Section Backtranslation. 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 ir_to_clight_step @@ -1812,7 +1946,7 @@ Section Backtranslation. Set Nested Proofs Allowed. unfold wf_c_state in WFC. des_ifs. rename s into stmt, k into k_c, m into m_c. - destruct WFC as (WFC0 & WFC1 & WFC2 & WFC3 & WFC4 & WFC5). + destruct WFC as ((CNT_INJ & WFC0) & WFC1 & WFC2 & WFC3 & WFC4 & WFC5). 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). move STEP after WFC5. inv STEP. @@ -1893,157 +2027,55 @@ Section Backtranslation. assert (WFC_NEXT: wf_c_state 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. - - clear CUR_SWITCH_STAR. move WFC0 after le_next. + - unfold wf_counters. split. auto. + clear CUR_SWITCH_STAR. move WFC0 after le_next. ii. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. unfold wf_counter in WFC6. des. unfold wf_counter. splits; auto. exists b1. splits; auto. - + - - (* MOVE *) - 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. - - eapply bind_parameters_valid_access. eapply ENV_BIND. + + eapply bind_parameters_valid_access. eapply ENV_BIND. eapply alloc_variables_valid_access. eapply ENV_ALLOC. - - (* MOVE *) - 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. - eapply mem_delta_apply_wf_valid_access. eapply DELTA_C. eapply Mem.store_valid_access_1. eapply CNT_CUR_STORE. auto. + destruct (Pos.eq_dec id id_cur). * subst id. clarify. ss. rewrite FIND_CNT_CUR in WFC7. clarify. - - - 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. - erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. admit. (*ez*) } erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. 2:{ admit. (* same ez *) } - - 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. - 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. - + 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. + admit. (*ez*) + * ss. erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. + 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. admit. (*ez*) } + erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. + 2:{ admit. (* same ez *) } + 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 WFC7. } + 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, WFC7. + rewrite FIND_CNT_CUR in WFC7. 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 WFC9. auto. + - clear CUR_SWITCH_STAR. move WFC1 after le_next. + (* env: continuation env, also extcall *) - TODO + TODO + econs. 4: apply WFC1. + admit. } 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). { admit. } From b4b37244ced65690f25017ec7aad6c6f35e2ed72 Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 11 Sep 2023 19:12:26 +0900 Subject: [PATCH 138/174] WIP --- security/Backtranslation.v | 32 ++++++++++++++++++++++++-------- 1 file changed, 24 insertions(+), 8 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 9e6af51b12..d4ce7411b4 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1186,19 +1186,33 @@ Section Backtranslation. Proof. Admitted. - Inductive wf_c_cont (ge: Clight.genv) (m: mem): (cont) -> Prop := + 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 - ck - f e le s1 s2 ck' - (WFEUB: wf_env_unique_blocks e) - (WFEM: wf_env_mem ge (comp_of f) e m) + m ck + f e le s1 s2 m' ck' + (WFENV: wf_env ge e) (CK: ck = Kcall None f e le (Kloop1 s1 s2 ck')) - (IND: wf_c_cont ge m 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. + (* Inductive wf_c_cont (ge: Clight.genv) (m: mem): (cont) -> Prop := *) + (* | wf_c_cont_nil *) + (* : *) + (* wf_c_cont ge m Kstop *) + (* | wf_c_cont_cons *) + (* ck *) + (* f e le s1 s2 ck' *) + (* (WFEUB: wf_env_unique_blocks e) *) + (* (WFEM: wf_env_mem ge (comp_of f) e m) *) + (* (CK: ck = Kcall None f e le (Kloop1 s1 s2 ck')) *) + (* (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). @@ -1211,8 +1225,10 @@ Section Backtranslation. match cst with | State f stmt k_c e le m_c => wf_counters ge m_c tr cnts /\ - wf_c_cont ge m_c k_c /\ wf_c_stmt ge (comp_of f) cnts id ttr stmt /\ - (wf_env ge e /\ wf_env_unique_blocks e /\ wf_env_mem ge (comp_of f) e m_c) + (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 + (* (wf_env ge e /\ wf_env_unique_blocks e /\ wf_env_mem ge (comp_of f) e m_c) *) | _ => False end. (* Definition wf_c_state (ge: Clight.genv) (tr ttr: bundle_trace) (cnts: cnt_ids) id (cst: Clight.state) := *) From 2b66207671e141d4f2d45f54fcd636f999c2940a Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 13 Sep 2023 14:17:48 +0900 Subject: [PATCH 139/174] defined wunchanged_on --- security/Backtranslation.v | 53 +++++++------ security/MemoryWeak.v | 158 +++++++++++++++++++++++++++++++++++++ 2 files changed, 187 insertions(+), 24 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index d4ce7411b4..ed10b0186b 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1170,21 +1170,26 @@ Section Backtranslation. (* Definition wf_counters_find (ge: Senv.t) (cnts: cnt_ids) := *) (* forall id cnt, cnts ! id = Some cnt -> exists b_cnt, Senv.find_symbol ge cnt = Some b_cnt. *) - Definition wf_env_unique_blocks (e: env) := - forall id1 id2 b1 ty1 b2 ty2, e ! id1 = Some (b1, ty1) -> e ! id2 = Some (b2, ty2) -> id1 <> id2 -> b1 <> b2. + (* Definition wf_env_unique_blocks (e: env) := *) + (* forall id1 id2 b1 ty1 b2 ty2, e ! id1 = Some (b1, ty1) -> e ! id2 = Some (b2, ty2) -> id1 <> id2 -> b1 <> b2. *) - Definition wf_env_mem (ge: Clight.genv) cp (e: env) (m: mem) := - let eranges := blocks_of_env ge e in - Forall (fun '(b, lo, hi) => Mem.range_perm m b lo hi Cur Freeable /\ Mem.can_access_block m b (Some cp)) eranges. + (* Definition wf_env_mem (ge: Clight.genv) cp (e: env) (m: mem) := *) + (* let eranges := blocks_of_env ge e in *) + (* Forall (fun '(b, lo, hi) => Mem.range_perm m b lo hi Cur Freeable /\ Mem.can_access_block m b (Some cp)) eranges. *) - Lemma wf_env_conds_implies_free_list - ge cp e m - (WFEUB: wf_env_unique_blocks e) - (WFEM: wf_env_mem ge cp e m) - : - exists m', Mem.free_list m (blocks_of_env ge e) cp = Some m'. - Proof. - Admitted. + (* Lemma wf_env_conds_implies_free_list *) + (* ge cp e m *) + (* (WFEUB: wf_env_unique_blocks e) *) + (* (WFEM: wf_env_mem ge cp e m) *) + (* : *) + (* exists m', Mem.free_list m (blocks_of_env ge e) cp = Some m'. *) + (* Proof. *) + (* Admitted. *) + + Definition not_inj_blks (j: meminj) (ebs: list block) := + Forall (fun b => j b = None) ebs. + + Definition blocks_of_env2 ge e : list block := (map (fun x => fst (fst x)) (blocks_of_env ge e)). Inductive wf_c_cont (ge: Clight.genv) : mem -> cont -> Prop := | wf_c_cont_nil @@ -1195,6 +1200,7 @@ Section Backtranslation. m ck f e le s1 s2 m' ck' (WFENV: wf_env ge e) + (NINJ: not_inj_blks (meminj_public 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') @@ -1227,7 +1233,7 @@ Section Backtranslation. wf_counters 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 + (wf_env ge e /\ (not_inj_blks (meminj_public ge) (blocks_of_env2 ge e))) (* (wf_env ge e /\ wf_env_unique_blocks e /\ wf_env_mem ge (comp_of f) e m_c) *) | _ => False end. @@ -1941,7 +1947,6 @@ Section Backtranslation. - Lemma ir_to_clight_step (ge_i: Asm.genv) (ge_c: Clight.genv) cnts pars ist1 ev ist2 @@ -1962,10 +1967,10 @@ Section Backtranslation. Set Nested Proofs Allowed. 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) & WFC1 & WFC2 & WFC3 & WFC4 & WFC5). + destruct WFC as ((CNT_INJ & WFC0) & (m_freeenv & FREEENV & WFC1) & WFC2 & WFC3 & WFC4). 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). - move STEP after WFC5. inv STEP. + move STEP after WFC4. inv STEP. - assert (id = id_cur). { unfold match_cur_fun in MS2. des. rewrite MS7 in IDCUR. clarify. } @@ -2046,7 +2051,7 @@ Section Backtranslation. - unfold wf_counters. split. auto. clear CUR_SWITCH_STAR. move WFC0 after le_next. ii. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. - unfold wf_counter in WFC6. des. unfold wf_counter. 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. @@ -2054,7 +2059,7 @@ Section Backtranslation. eapply Mem.store_valid_access_1. eapply CNT_CUR_STORE. auto. + destruct (Pos.eq_dec id id_cur). - * subst id. clarify. ss. rewrite FIND_CNT_CUR in WFC7. clarify. + * subst id. clarify. ss. rewrite FIND_CNT_CUR in WFC6. clarify. erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. admit. (*ez*) } erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. @@ -2074,17 +2079,17 @@ Section Backtranslation. 2:{ admit. (* same ez *) } 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 WFC7. } + 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, WFC7. - rewrite FIND_CNT_CUR in WFC7. clarify. rename cnt into cnt_cur. + 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 WFC9. auto. + rewrite WFC8. auto. - - clear CUR_SWITCH_STAR. move WFC1 after le_next. + - clear CUR_SWITCH_STAR. move WFC1 after le_next. move WFC4 after WFC1. move FREEENV after WFC4. (* env: continuation env, also extcall *) diff --git a/security/MemoryWeak.v b/security/MemoryWeak.v index aaaa5db491..0549366c95 100644 --- a/security/MemoryWeak.v +++ b/security/MemoryWeak.v @@ -1637,3 +1637,161 @@ Section PROPS. 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' -> + (forall i, ofs <= i < ofs + size_chunk chunk -> ~ P b i) -> + 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' -> + (forall i, ofs <= i < ofs + Z.of_nat (length bytes) -> ~ P b i) -> + 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. From acbf32e4e28a9abc2a3a048c78535b770135fcef Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 13 Sep 2023 19:50:51 +0900 Subject: [PATCH 140/174] WIP --- security/Backtranslation.v | 351 +++++++++++++++++++++++++++++++------ security/MemoryWeak.v | 2 - 2 files changed, 299 insertions(+), 54 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index ed10b0186b..ad10570f24 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -6,7 +6,7 @@ Require Import Split. Require Import Tactics. Require Import riscV.Asm. -Require Import BtBasics BtInfoAsm MemoryDelta. +Require Import BtBasics BtInfoAsm MemoryDelta MemoryWeak. Require Import Ctypes Clight. Section Backtranslation. @@ -1310,55 +1310,12 @@ Section Backtranslation. End INVS. - (* Section MEM. *) - - (* Import Mem. *) - - (* Lemma store_unmapped_inj_inv : *) - (* forall f chunk m1 b1 ofs v1 cp n m2, *) - (* Mem.mem_inj f m1 m2 -> *) - (* Mem.store chunk m2 b1 ofs v1 cp = Some n -> *) - (* (forall b ofs, f b <> Some (b1, ofs)) -> *) - (* Mem.mem_inj f m1 n. *) - (* Proof. *) - (* intros. constructor. *) - (* (* perm *) *) - (* - intros. eapply perm_store_1. eapply H0. eapply mi_perm; eauto with mem. *) - (* (* own *) *) - (* - intros. rewrite <- store_can_access_block_inj. 2: eauto. eapply mi_own; eauto. *) - (* (* align *) *) - (* - intros. eapply mi_align with (ofs := ofs0) (p := p); eauto. *) - (* (* mem_contents *) *) - (* - intros. rewrite (store_mem_contents _ _ _ _ _ _ _ H0). *) - (* rewrite PMap.gso. eapply mi_memval; eauto with mem. *) - (* intros EQ; subst. eapply H1. eauto. *) - (* Qed. *) - - (* Lemma store_unmapped_inject_inv : *) - (* forall f chunk m1 b1 ofs v1 cp n m2, *) - (* inject f m1 m2 -> *) - (* store chunk m2 b1 ofs v1 cp = Some n -> *) - (* (forall b ofs, f b <> Some (b1, ofs)) -> *) - (* inject f m1 n. *) - (* Proof. *) - (* intros. inversion H. *) - (* constructor. *) - (* (* inj *) *) - (* - eapply store_unmapped_inj_inv; eauto. *) - (* (* freeblocks *) *) - (* - eauto with mem. *) - (* (* mappedblocks *) *) - (* - eauto with mem. *) - (* (* no overlap *) *) - (* - red; intros. eauto with mem. *) - (* (* representable *) *) - (* - intros. eapply mi_representable; try eassumption. *) - (* (* perm inv *) *) - (* - intros. exploit mi_perm_inv0; eauto using perm_store_1. *) - (* intuition eauto using perm_store_1, perm_store_2. *) - (* Qed. *) - - (* End MEM. *) + Section MEM. + + Import Mem. + + + End MEM. Section PROOF. @@ -2091,12 +2048,302 @@ Section Backtranslation. - clear CUR_SWITCH_STAR. move WFC1 after le_next. move WFC4 after WFC1. move FREEENV after WFC4. + 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. + + hexploit alloc_variables_exists_free_list. eapply ENV_ALLOC. ss. ss. ss. intros; des. + + 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. + + 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). + + Lemma wunchanged_on_free_list + 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. + + + TODO + + + esplits; eauto. econs. 1,2,3: eauto. + + + + (* env: continuation env, also extcall *) TODO - econs. 4: apply WFC1. - admit. } 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). { admit. } diff --git a/security/MemoryWeak.v b/security/MemoryWeak.v index 0549366c95..745949b785 100644 --- a/security/MemoryWeak.v +++ b/security/MemoryWeak.v @@ -1704,7 +1704,6 @@ Qed. Lemma store_wunchanged_on: forall chunk m b ofs v cp m', store chunk m b ofs v cp = Some m' -> - (forall i, ofs <= i < ofs + size_chunk chunk -> ~ P b i) -> wunchanged_on m m'. Proof. intros; constructor; intros. @@ -1716,7 +1715,6 @@ Qed. Lemma storebytes_wunchanged_on: forall m b ofs bytes cp m', storebytes m b ofs bytes cp = Some m' -> - (forall i, ofs <= i < ofs + Z.of_nat (length bytes) -> ~ P b i) -> wunchanged_on m m'. Proof. intros; constructor; intros. From cc44ee84ce0ae09093078bae9060717e4f223d67 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 14 Sep 2023 16:54:06 +0900 Subject: [PATCH 141/174] defined some admits --- security/Backtranslation.v | 23 +++++++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index ad10570f24..b4c403608c 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -774,8 +774,8 @@ Section Backtranslation. 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. - Admitted. + Definition next_id {A} (l: list (ident * A)): ident := + Pos.succ (fold_left (fun x '(i, _) => if (x [] + | 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: positive) (gds: list (ident * globdef Asm.fundef unit)): params_of. - Admitted. + Definition gen_params (m: ident) (gds: list (ident * globdef Asm.fundef unit)): params_of := + fold_left (fun pt '(id, gd) => + match gen_params_one m gd with | Some ps => PTree.set id ps pt | None => pt end) gds (@PTree.empty _). Definition wf_params_of (pars: params_of) := (forall id params, (pars ! id = Some params) -> list_norepet (var_names params)). From 95d27faf81660a7dd5701bbd49f79b1fa4fc1236 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 14 Sep 2023 19:39:34 +0900 Subject: [PATCH 142/174] WIP --- security/Backtranslation.v | 79 +++++++++++++++++++++++++++++++++++--- 1 file changed, 74 insertions(+), 5 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index b4c403608c..d3339b60eb 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -2320,7 +2320,7 @@ Section Backtranslation. { eapply wunchanged_on_implies. eapply bind_parameters_wunchanged_on. apply ENV_BIND. ss. } intros (m_f' & FREE). - Lemma wunchanged_on_free_list + 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) @@ -2346,13 +2346,82 @@ Section Backtranslation. 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') + : + wunchanged_on (fun b _ => Mem.valid_block m b) 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. + Qed. - TODO + 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. + + 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. + + 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'. + + 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. + + eapply wf_c_cont_wunchanged_on. eapply WFC1. apply WUFREE. + - + + + TODO - esplits; eauto. econs. 1,2,3: eauto. - - (* env: continuation env, also extcall *) From b3e98679e0335fda73b98186180fcc2b28a4a73a Mon Sep 17 00:00:00 2001 From: ldj Date: Sat, 16 Sep 2023 15:35:58 +0900 Subject: [PATCH 143/174] cleanup --- security/Backtranslation.v | 662 ++++++++++++++++++------------------- 1 file changed, 328 insertions(+), 334 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index d3339b60eb..fff135a182 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1917,6 +1917,334 @@ Section Backtranslation. 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') + : + wunchanged_on (fun b _ => Mem.valid_block m b) 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. + 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 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 ir_to_clight_step @@ -2062,359 +2390,25 @@ Section Backtranslation. rewrite WFC8. auto. - clear CUR_SWITCH_STAR. move WFC1 after le_next. move WFC4 after WFC1. move FREEENV after WFC4. - - 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. - hexploit alloc_variables_exists_free_list. eapply ENV_ALLOC. ss. ss. ss. intros; des. - - 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. - 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). - - 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') - : - wunchanged_on (fun b _ => Mem.valid_block m b) 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. - Qed. - 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. - - 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. - 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'. - - 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. - eapply wf_c_cont_wunchanged_on. eapply WFC1. apply WUFREE. - From 12801ff9053476f453f2156b316f53d125d4236c Mon Sep 17 00:00:00 2001 From: ldj Date: Sat, 16 Sep 2023 22:30:28 +0900 Subject: [PATCH 144/174] WIP --- security/Backtranslation.v | 70 +++++--------------------------------- 1 file changed, 8 insertions(+), 62 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index fff135a182..5c023dab27 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1061,7 +1061,7 @@ Section Backtranslation. 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_mem_trace + Lemma match_symbs_code_bundle_trace ge1 ge2 (MSYMB: match_symbs ge1 ge2) cp cnt tr @@ -1162,9 +1162,6 @@ Section Backtranslation. Definition cnt_ids := PTree.t ident. - (* well-formedness *) - (* Definition wf_env_cnt_ids (e: env) (cnts: cnt_ids) := forall id cnt, cnts ! id = Some cnt -> e ! cnt = None. *) - 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) /\ @@ -1176,30 +1173,6 @@ Section Backtranslation. (forall id b (f: function), (Genv.find_symbol ge id = Some b) -> (Genv.find_funct_ptr ge b = Some (Internal f)) -> (exists cnt, (cnts ! id = Some cnt) /\ (wf_counter ge m (comp_of f) (length (get_id_tr tr id)) cnt))). - (* Definition wf_counters (ge: Clight.genv) (m: mem) (tr: bundle_trace) (cnts: cnt_ids) := *) - (* forall id b (f: function) cnt, *) - (* (Genv.find_symbol ge id = Some b) -> (Genv.find_funct_ptr ge b = Some (Internal f)) -> *) - (* (cnts ! id = Some cnt) -> *) - (* (wf_counter ge m (comp_of f) (length (get_id_tr tr id)) cnt). *) - - (* Definition wf_counters_find (ge: Senv.t) (cnts: cnt_ids) := *) - (* forall id cnt, cnts ! id = Some cnt -> exists b_cnt, Senv.find_symbol ge cnt = Some b_cnt. *) - - (* Definition wf_env_unique_blocks (e: env) := *) - (* forall id1 id2 b1 ty1 b2 ty2, e ! id1 = Some (b1, ty1) -> e ! id2 = Some (b2, ty2) -> id1 <> id2 -> b1 <> b2. *) - - (* Definition wf_env_mem (ge: Clight.genv) cp (e: env) (m: mem) := *) - (* let eranges := blocks_of_env ge e in *) - (* Forall (fun '(b, lo, hi) => Mem.range_perm m b lo hi Cur Freeable /\ Mem.can_access_block m b (Some cp)) eranges. *) - - (* Lemma wf_env_conds_implies_free_list *) - (* ge cp e m *) - (* (WFEUB: wf_env_unique_blocks e) *) - (* (WFEM: wf_env_mem ge cp e m) *) - (* : *) - (* exists m', Mem.free_list m (blocks_of_env ge e) cp = Some m'. *) - (* Proof. *) - (* Admitted. *) Definition not_inj_blks (j: meminj) (ebs: list block) := Forall (fun b => j b = None) ebs. @@ -1221,26 +1194,9 @@ Section Backtranslation. (IND: wf_c_cont ge m' ck') : wf_c_cont ge m ck. - (* Inductive wf_c_cont (ge: Clight.genv) (m: mem): (cont) -> Prop := *) - (* | wf_c_cont_nil *) - (* : *) - (* wf_c_cont ge m Kstop *) - (* | wf_c_cont_cons *) - (* ck *) - (* f e le s1 s2 ck' *) - (* (WFEUB: wf_env_unique_blocks e) *) - (* (WFEM: wf_env_mem ge (comp_of f) e m) *) - (* (CK: ck = Kcall None f e le (Kloop1 s1 s2 ck')) *) - (* (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). - (* match cnts ! id with *) - (* | Some cnt => stmt = code_bundle_trace ge cp cnt (get_id_tr tr id) *) - (* | _ => False *) - (* end. *) Definition wf_c_state (ge: Clight.genv) (tr ttr: bundle_trace) (cnts: cnt_ids) id (cst: Clight.state) := match cst with @@ -1252,14 +1208,6 @@ Section Backtranslation. (* (wf_env ge e /\ wf_env_unique_blocks e /\ wf_env_mem ge (comp_of f) e m_c) *) | _ => False end. - (* Definition wf_c_state (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 m_c tr cnts /\ wf_counters_find ge cnts /\ *) - (* wf_c_cont ge m_c k_c /\ wf_c_stmt ge (comp_of f) cnts id ttr stmt /\ *) - (* (wf_env ge e /\ wf_env_unique_blocks e /\ wf_env_mem ge (comp_of f) e m_c) *) - (* | _ => False *) - (* end. *) @@ -1300,7 +1248,6 @@ Section Backtranslation. ck ik f e le cnt id ck' b ik' - (* (FUN: match_cur_fun ge b f id) *) (FUN: Genv.find_funct_ptr ge b = Some (Internal f)) (ID: Genv.invert_symbol ge b = Some id) (CNT: cnts ! id = Some cnt) @@ -1325,13 +1272,6 @@ Section Backtranslation. End INVS. - Section MEM. - - Import Mem. - - - End MEM. - Section PROOF. @@ -2411,7 +2351,13 @@ Section Backtranslation. 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 + TODO From a1b0f7110716f48a2d1f0c1168298ef453f5e434 Mon Sep 17 00:00:00 2001 From: ldj Date: Sun, 17 Sep 2023 18:18:05 +0900 Subject: [PATCH 145/174] WIP --- security/Backtranslation.v | 458 ++++++++++++++++++++++++++++++++++--- 1 file changed, 432 insertions(+), 26 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 5c023dab27..0bb7758689 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -802,16 +802,6 @@ Section Backtranslation. fold_left (fun pt '(id, gd) => match gen_params_one m gd with | Some ps => PTree.set id ps pt | None => pt end) gds (@PTree.empty _). - 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_sig (pars: params_of) (ge: 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) -> *) - (* forall tyargs tyres cconv, (type_of_fundef f = Tfunction tyargs tyres cconv) -> (type_of_params params = tyargs). *) - 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 @@ -846,6 +836,17 @@ Section Backtranslation. 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 next_id_lt A (l: list (ident * A)) id a @@ -902,6 +903,42 @@ Section Backtranslation. 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. + + 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 GENPROOFS. @@ -1257,7 +1294,8 @@ Section Backtranslation. : match_cont ge tr cnts ck ik. - Definition match_params pars ge_i := (wf_params_of pars) /\ (wf_params_of_sig pars ge_i). + 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_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 @@ -1265,13 +1303,16 @@ Section Backtranslation. (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_i) + (match_params pars ge_c ge_i) | _, _ => False end. End INVS. + Definition meminj_same_block (j : meminj) := + forall b1 b2 del, j b1 = Some (b2, del) -> b1 = b2. + Section PROOF. @@ -2185,10 +2226,92 @@ Section Backtranslation. eapply wunchanged_on_free_list_preserves. eapply WU. all: eauto. 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 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 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 @@ -2215,8 +2338,9 @@ Section Backtranslation. - 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. + 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. @@ -2236,7 +2360,7 @@ Section Backtranslation. { rewrite map_length. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } 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. } + { destruct MS5 as (_ & WFP1 & _). exploit WFP1. apply FINDF. apply FINDB. apply PARS_NEXT. ss. } 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. @@ -2286,6 +2410,23 @@ Section Backtranslation. (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_NINJ: not_inj_blks (meminj_public 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. + unfold meminj_public. des_ifs. exfalso. simpl in Heq. + move MS1 after Heq0. destruct MS1 as (MM1 & MM2 & MM3). + erewrite match_symbs_meminj_public in MEMINJ_CNT. + 2:{ destruct MS0 as (MS0 & _). apply MS0. } + hexploit Mem.valid_block_inject_2. 2: eapply MEMINJ_CNT. + { unfold meminj_public. setoid_rewrite Heq. rewrite Heq0. eauto. } + eapply alloc_variables_one_fresh_block. eapply ENV_ALLOC. + { rewrite app_nil_r. eapply MP1. eauto. } + ss. eapply H0. + } + assert (WFC_NEXT: wf_c_state 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. - unfold wf_counters. split. auto. @@ -2356,21 +2497,291 @@ Section Backtranslation. subst f_next. unfold comp_of. ss. apply match_symbs_code_bundle_trace. destruct MS0 as (MS0 & _); auto. - - clear CUR_SWITCH_STAR. move - + - 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. + - apply ENV_NINJ. + } - TODO + 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. + } + 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. + } - (* env: continuation env, also extcall *) + 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. + + - 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. + + 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)). + { destruct MS2 as (MFUN0 & MFUN1). auto. } - TODO + TODO + + exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } + 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. } + + 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). + 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. } + + 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_NINJ: not_inj_blks (meminj_public 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. + unfold meminj_public. des_ifs. exfalso. simpl in Heq. + move MS1 after Heq0. destruct MS1 as (MM1 & MM2 & MM3). + erewrite match_symbs_meminj_public in MEMINJ_CNT. + 2:{ destruct MS0 as (MS0 & _). apply MS0. } + hexploit Mem.valid_block_inject_2. 2: eapply MEMINJ_CNT. + { unfold meminj_public. setoid_rewrite Heq. rewrite Heq0. eauto. } + eapply alloc_variables_one_fresh_block. eapply ENV_ALLOC. + { rewrite app_nil_r. eapply MP1. eauto. } + ss. eapply H0. + } + + assert (WFC_NEXT: wf_c_state 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. + - unfold wf_counters. split. 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. + + destruct (Pos.eq_dec id id_cur). + * subst id. clarify. ss. rewrite FIND_CNT_CUR in WFC6. clarify. + erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. + 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. admit. (*ez*) } + erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. + 2:{ admit. (* same ez *) } + 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. + admit. (*ez*) + * ss. erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. + 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. admit. (*ez*) } + erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. + 2:{ admit. (* same ez *) } + 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. + + - apply ENV_NINJ. + } - admit. } 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). - { admit. } + { 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. + } exists cst2. split. 2:{ left. exists id_next. split. apply WFC_NEXT. eexists. eapply MS_NEXT. } @@ -2436,13 +2847,8 @@ Section Backtranslation. } traceEq. - - - - - - (* TODO *) Admitted. From 3f6683360ca4ecc080f095260261e1150e0cebad Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 18 Sep 2023 17:33:14 +0900 Subject: [PATCH 146/174] WIP --- security/Backtranslation.v | 352 ++++++++++++++++++++----------------- 1 file changed, 191 insertions(+), 161 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 0bb7758689..b1a34b6a22 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1211,8 +1211,8 @@ Section Backtranslation. (Genv.find_symbol ge id = Some b) -> (Genv.find_funct_ptr ge b = Some (Internal f)) -> (exists cnt, (cnts ! id = Some cnt) /\ (wf_counter ge m (comp_of f) (length (get_id_tr tr id)) cnt))). - Definition not_inj_blks (j: meminj) (ebs: list block) := - Forall (fun b => j b = None) ebs. + 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)). @@ -1225,7 +1225,7 @@ Section Backtranslation. m ck f e le s1 s2 m' ck' (WFENV: wf_env ge e) - (NINJ: not_inj_blks (meminj_public ge) (blocks_of_env2 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') @@ -1235,17 +1235,30 @@ Section Backtranslation. 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: 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 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_inj_blks (meminj_public ge) (blocks_of_env2 ge e))) + (wf_env ge e /\ (not_global_blks (ge) (blocks_of_env2 ge e)) /\ (wf_c_nb ge m_c)) (* (wf_env ge e /\ wf_env_unique_blocks e /\ wf_env_mem ge (comp_of f) e m_c) *) | _ => False end. + 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) := @@ -2178,8 +2191,9 @@ Section Backtranslation. 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 (fun b _ => Mem.valid_block m b) m m'. + wunchanged_on P m m'. Proof. revert_until d. induction d; ii; ss. { cbn in APPD. clarify. apply wunchanged_on_refl. } @@ -2189,6 +2203,7 @@ Section Backtranslation. 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 @@ -2289,6 +2304,13 @@ Section Backtranslation. 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 : @@ -2330,7 +2352,7 @@ Section Backtranslation. Set Nested Proofs Allowed. 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). + 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). move STEP after WFC4. inv STEP. @@ -2410,26 +2432,47 @@ Section Backtranslation. (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_NINJ: not_inj_blks (meminj_public ge_c) (blocks_of_env2 ge_c e_next)). + 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. - unfold meminj_public. des_ifs. exfalso. simpl in Heq. - move MS1 after Heq0. destruct MS1 as (MM1 & MM2 & MM3). - erewrite match_symbs_meminj_public in MEMINJ_CNT. - 2:{ destruct MS0 as (MS0 & _). apply MS0. } - hexploit Mem.valid_block_inject_2. 2: eapply MEMINJ_CNT. - { unfold meminj_public. setoid_rewrite Heq. rewrite Heq0. eauto. } - eapply alloc_variables_one_fresh_block. eapply ENV_ALLOC. - { rewrite app_nil_r. eapply MP1. eauto. } - ss. eapply H0. + 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 (ENV_NINJ: not_inj_blks (meminj_public 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. *) + (* unfold meminj_public. des_ifs. exfalso. simpl in Heq. *) + (* move MS1 after Heq0. destruct MS1 as (MM1 & MM2 & MM3). *) + (* erewrite match_symbs_meminj_public in MEMINJ_CNT. *) + (* 2:{ destruct MS0 as (MS0 & _). apply MS0. } *) + (* hexploit Mem.valid_block_inject_2. 2: eapply MEMINJ_CNT. *) + (* { unfold meminj_public. setoid_rewrite Heq. rewrite Heq0. eauto. } *) + (* eapply alloc_variables_one_fresh_block. eapply ENV_ALLOC. *) + (* { rewrite app_nil_r. eapply MP1. eauto. } *) + (* ss. eapply H0. *) + (* } *) + assert (WFC_NEXT: wf_c_state 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. - - unfold wf_counters. split. auto. + { 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. @@ -2501,7 +2544,12 @@ Section Backtranslation. eapply alloc_variables_wf_params_of_symb. eapply ENV_ALLOC. eapply MP3. rewrite app_nil_r. apply PARS_NEXT. - - apply ENV_NINJ. + - 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). @@ -2608,17 +2656,20 @@ Section Backtranslation. assert (FIND_FUN_C: Genv.find_funct_ptr ge_c cur = Some (Internal f)). { destruct MS2 as (MFUN0 & MFUN1). auto. } - TODO - exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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)). + 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. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } 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. } + { 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. 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. @@ -2627,13 +2678,16 @@ Section Backtranslation. 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. } + 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 k0)). + 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). @@ -2652,53 +2706,80 @@ Section Backtranslation. 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. } + + 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. } - 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. + subst id. + assert (cnt = cnt_next). + { rewrite CNTS_NEXT in CNT. clarify. } + subst cnt. clear ID CNT. - assert (ENV_NINJ: not_inj_blks (meminj_public 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. - unfold meminj_public. des_ifs. exfalso. simpl in Heq. - move MS1 after Heq0. destruct MS1 as (MM1 & MM2 & MM3). - erewrite match_symbs_meminj_public in MEMINJ_CNT. - 2:{ destruct MS0 as (MS0 & _). apply MS0. } - hexploit Mem.valid_block_inject_2. 2: eapply MEMINJ_CNT. - { unfold meminj_public. setoid_rewrite Heq. rewrite Heq0. eauto. } - eapply alloc_variables_one_fresh_block. eapply ENV_ALLOC. - { rewrite app_nil_r. eapply MP1. eauto. } - ss. eapply H0. + 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. - assert (WFC_NEXT: wf_c_state 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. + 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_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. - clear CUR_SWITCH_STAR. move WFC0 after le_next. + move WFC0 after cst2. ii. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; auto. - unfold wf_counter in WFC5. des. unfold wf_counter. splits; auto. + unfold wf_counter in WFC1. 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. + + + + 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. + + 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. + intros CONTRA. unfold not_global_blks in WFC4. unfold blocks_of_env2, blocks_of_env in *. + rewrite map_map in WFC4, CONTRA. rewrite Forall_forall in WFC4. specialize (WFC4 _ CONTRA). + apply Genv.find_invert_symbol in WFC5. setoid_rewrite WFC5 in WFC4. inv WFC4. + + destruct (Pos.eq_dec id id_cur). - * subst id. clarify. ss. rewrite FIND_CNT_CUR in WFC6. clarify. + * subst id. clarify. ss. + + TODO + + rewrite FIND_CNT_CUR in H. clarify. erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. admit. (*ez*) } erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. @@ -2728,124 +2809,73 @@ Section Backtranslation. 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. - - apply ENV_NINJ. - } - 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. + TODO - - 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. + admit. } + + assert (MS_NEXT: match_state ge_i ge_c (meminj_public ge_i) ttr cnts pars id_next (Some (b, m2, ik')) cst2). + { admit. } - - move MS4 after ENV_NINJ. econs 2. 4,5,6: eauto. all: auto. - apply Genv.find_invert_symbol. apply FIND_CUR_C. - } 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. + 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_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 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)). + 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). + assert (EVRETV: eventval_to_val ge_c evretv = vretv). { destruct MS0 as (MSENV & MGENV). inv TR. - eapply eventval_list_match_list_eventval_to_list_val. eapply match_symbs_eventval_list_match; eauto. + eapply eventval_match_eventval_to_val. eapply match_symbs_eventval_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. } - } + { 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. assert (fd_cur = AST.Internal f_i_cur). + { rewrite FINDFD in FINDF_I_CUR; clarify. } + subst fd_cur. eapply sem_cast_proj_rettype. ss. eapply H0. + - eapply FREENEXT. } - { 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. } + 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 FINDF_I_CUR. 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. + assert (fd_cur = AST.Internal f_i_cur). + { rewrite FINDFD in FINDF_I_CUR; clarify. } + subst fd_cur. ss. erewrite proj_rettype_to_type_rettype_of_type_eq. 2: eapply H0. + eapply match_senv_eventval_match. 2: eapply H0. destruct MS0 as (MS0 & _). auto. } - traceEq. + 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. + + - + From 4011a27bccd0490a0b462224e47ab28880981a04 Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 19 Sep 2023 14:50:31 +0900 Subject: [PATCH 147/174] WIP --- security/Backtranslation.v | 162 ++++++++++++++++++++++--------------- 1 file changed, 97 insertions(+), 65 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index b1a34b6a22..32bdca6e9b 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -2329,6 +2329,61 @@ Section Backtranslation. 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 ir_to_clight_step @@ -2736,80 +2791,60 @@ Section Backtranslation. 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. - + - - 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. - - eapply mem_valid_access_wunchanged_on. eapply WFC6. + + 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. - intros CONTRA. unfold not_global_blks in WFC4. unfold blocks_of_env2, blocks_of_env in *. - rewrite map_map in WFC4, CONTRA. rewrite Forall_forall in WFC4. specialize (WFC4 _ CONTRA). - apply Genv.find_invert_symbol in WFC5. setoid_rewrite WFC5 in WFC4. inv WFC4. - - + destruct (Pos.eq_dec id id_cur). - * subst id. clarify. ss. - - TODO - - rewrite FIND_CNT_CUR in H. clarify. - erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. - 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. admit. (*ez*) } - erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. - 2:{ admit. (* same ez *) } - 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. + 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_C in H. clarify. } + subst b0. assert (f0 = f). + { rewrite FINDF_C_CUR in H0. clarify. } + subst f0. 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. admit. (*ez*) - * ss. erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. - 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. admit. (*ez*) } - erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. - 2:{ admit. (* same ez *) } - 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. + * 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 WFC8. auto. + 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). + } + + assert (MS_NEXT: match_state ge_i ge_c (meminj_public ge_i) ttr cnts pars id_next (Some (b, m2, ik')) cst2). + { @@ -2817,9 +2852,6 @@ Section Backtranslation. admit. } - assert (MS_NEXT: match_state ge_i ge_c (meminj_public ge_i) ttr cnts pars id_next (Some (b, m2, ik')) cst2). - { admit. } - exists cst2. split. 2:{ left. exists id_next. split. apply WFC_NEXT. eexists. eapply MS_NEXT. } From 5321bbccb6c360d84ebb1a80cdf12c682f79c796 Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 20 Sep 2023 18:26:02 +0900 Subject: [PATCH 148/174] WIP --- security/Backtranslation.v | 630 ++++++++++++++++++++++++++++++++++++- security/Tactics.v | 2 +- 2 files changed, 624 insertions(+), 8 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 32bdca6e9b..e1f3b31394 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1310,13 +1310,18 @@ Section Backtranslation. 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_params pars ge_c ge_i) /\ + (match_cnts cnts ge_c k) | _, _ => False end. @@ -2382,7 +2387,36 @@ Section Backtranslation. ss. eapply Mem.free_unchanged_on. eapply Heq. ii. apply H0; clear H0. left; 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 star_cut_middle + stepk 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_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_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. @@ -2409,7 +2443,7 @@ Section Backtranslation. 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). + destruct MS as (MS0 & MS1 & MS2 & MS3 & MS4 & MS5 & MCNTS). move STEP after WFC4. inv STEP. - assert (id = id_cur). @@ -2618,14 +2652,14 @@ Section Backtranslation. 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. } @@ -2841,17 +2875,598 @@ Section Backtranslation. 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. assert (fd_cur = AST.Internal f_i_cur). + { rewrite FINDFD in FINDF_I_CUR; clarify. } + subst fd_cur. eapply sem_cast_proj_rettype. ss. 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 FINDF_I_CUR. 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. + assert (fd_cur = AST.Internal f_i_cur). + { rewrite FINDFD in FINDF_I_CUR; clarify. } + subst fd_cur. ss. erewrite proj_rettype_to_type_rettype_of_type_eq. 2: eapply H0. + eapply match_senv_eventval_match. 2: eapply H0. destruct MS0 as (MS0 & _). auto. + } + 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. + + - assert (id = id_cur). + { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } + subst id. rename id0 into id_next. + + 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_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)). + { destruct MS2 as (MFUN0 & MFUN1). auto. } + + exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } + destruct WF_CNT_CUR as (CNT_CUR_NPUB & cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). + + 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). + 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. } + + 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. + desH ECCASES; cycle 1. + + { subst d. unfold mem_delta_apply_wf in DELTA. simpl in DELTA. inversion DELTA; clear DELTA. subst m1'. + + 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) + : + exists vargs2 vretv2, + (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))) 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. 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. + } + { instantiate (1:=Val.load_result chunk v). + + TODO + + + destruct v; ss. + - destruct chunk; ss; inv H2; ss. + - destruct chunk; ss. all: simpl_expr. + + inv H2. + - esplits. + + erewrite eventval_list_match_vals_to_eventvals. 2: eapply H. + eapply list_eventval_to_expr_val_eval; auto. eapply eventval_list_match_transl. + eapply match_senv_eventval_list_match; eauto. + + econs. eapply eventval_list_match_transl_val. 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. eapply eventval_match_sem_cast. + erewrite eventval_match_eventval_to_val. + eapply match_senv_eventval_match. eauto. eapply H. eapply match_senv_eventval_match. eauto. eapply H. + + econs. erewrite eventval_match_eventval_to_val. + eapply match_senv_eventval_match. eauto. eapply H. eapply match_senv_eventval_match. eauto. eapply H. + Qed. + + 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. + } + { TODO + + Lemma match_symbs_extcall_known_obs + ge1 ge2 + (MS: match_symbs ge1 ge2) + ef m1 vargs tr vretv m2 + (EK: external_call_known_observables ef ge1 m1 vargs tr vretv m2) + : + external_call_known_observables ef ge2 m1 vargs tr vretv m2. + Proof. + pose proof MS as MS0. destruct MS as (MS1 & MS2 & MS3). + unfold external_call_known_observables in *. des_ifs; ss; des. all: splits; [inv EK; clarify | auto]. + - inv H; clarify. econs. econs; auto. rewrite MS3; auto. eapply match_symbs_eventval_match; eauto. + - inv H; clarify. econs. econs; auto. rewrite MS3; auto. eapply match_symbs_eventval_match; eauto. + - econs; eauto. eapply match_symbs_eventval_list_match; eauto. + - econs; eauto. eapply match_symbs_eventval_match; eauto. + Qed. + external_call ef ge vargs m t vres m' -> + + (* Lemma match_symbs_vals_to_eventvals *) + (* ge1 ge2 *) + (* (MS: match_symbs ge1 ge2) *) + (* varg *) + (* : *) + (* val_to_eventval ge1 varg = val_to_eventval ge2 varg. *) + (* Proof. *) + (* destruct varg; ss. destruct MS as (MS1 & MS2 & MS3). unfold senv_invert_symbol_total. des_ifs. *) + (* - apply Senv.invert_find_symbol in Heq, Heq0. apply MS2 in Heq. apply Senv.find_invert_symbol in Heq, Heq0. *) + (* rewrite Heq in Heq0; clarify. *) + (* - apply Senv.invert_find_symbol in Heq. apply MS2 in Heq. apply Senv.find_invert_symbol in Heq. clarify. *) + (* - *) + (* - *) + + (* Lemma match_symbs_vals_to_eventvals *) + (* ge1 ge2 *) + (* (MS: match_symbs ge1 ge2) *) + (* vargs *) + (* : *) + (* vals_to_eventvals ge1 vargs = vals_to_eventvals ge2 vargs. *) + + Lemma extcall_known_observables_eval_args + (ge0: Senv.t) (ge: genv) + (MS: match_symbs ge0 ge) + ef m1 vargs tr vretv m2 + (EK: external_call_known_observables ef ge0 m1 vargs tr vretv m2) + e cp le m' + (WFE : wf_env ge e) + : + eval_exprlist ge e cp le m' (list_eventval_to_list_expr (vals_to_eventvals ge0 vargs)) (list_typ_to_typelist (sig_args (ef_sig ef))) vargs. + Proof. + pose proof MS as MS0. destruct MS as (MS1 & MS2 & MS3). + 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. + econs. 3: econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. apply sem_cast_ptr. + - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. + econs. + { eapply ptr_of_id_ofs_eval; eauto. } + { rewrite ptr_of_id_ofs_typeof. apply sem_cast_ptr. } + econs. 3: econs. + { eapply val_load_result_aux in H2. eapply eventval_to_expr_val_eval; auto. + - + + - inv ENV; inv EV. pose proof SEM as SEM0. inv SEM. inv H5. econstructor 2. + { apply val_load_result_aux in H10. + eapply step_builtin. + - econstructor; eauto. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. eapply sem_cast_ptr. + econstructor; eauto. 3: econstructor. eapply eventval_to_expr_val_eval; auto. eapply eventval_match_wf_eventval_ge; eauto. + eapply eventval_match_sem_cast. erewrite eventval_match_eventval_to_val; eauto. + - simpl. econstructor. econstructor 1; eauto. + } + simpl. econstructor 1. all: eauto. + + + + } + + + + 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. } + } + } + + + + + eapply step_call; simpl. + - ss. + - ec + + + + + + + + + + } + clear BOUND2 CUR_SWITCH_STAR. + + + 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_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_C in H. clarify. } + subst b0. assert (f0 = f). + { rewrite FINDF_C_CUR in H0. clarify. } + subst f0. 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. + admit. (*ez*) + * 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. assert (fd_cur = AST.Internal f_i_cur). + { rewrite FINDFD in FINDF_I_CUR; clarify. } + subst fd_cur. eapply sem_cast_proj_rettype. ss. 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 FINDF_I_CUR. 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. + assert (fd_cur = AST.Internal f_i_cur). + { rewrite FINDFD in FINDF_I_CUR; clarify. } + subst fd_cur. ss. erewrite proj_rettype_to_type_rettype_of_type_eq. 2: eapply H0. + eapply match_senv_eventval_match. 2: eapply H0. destruct MS0 as (MS0 & _). auto. + } + 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. + + + TODO - admit. } + + 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 ECCASES after DELTA. desH ECCASES; cycle 1. + { subst d. unfold mem_delta_apply_wf in *. ss. inv DELTA. + + TODO + + + 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 (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_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_C in H. clarify. } + subst b0. assert (f0 = f). + { rewrite FINDF_C_CUR in H0. clarify. } + subst f0. 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. + admit. (*ez*) + * 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. + } exists cst2. split. 2:{ left. exists id_next. split. apply WFC_NEXT. eexists. eapply MS_NEXT. } @@ -2906,7 +3521,8 @@ Section Backtranslation. } all: traceEq. traceEq. - - + + TODO diff --git a/security/Tactics.v b/security/Tactics.v index 4310c0f42e..2a2dfa9d6d 100644 --- a/security/Tactics.v +++ b/security/Tactics.v @@ -1,6 +1,6 @@ (* *********************************************************************) (* *) -(* Lemmas & Tactic form coq-sflib: *) +(* Lemmas & Tactic from coq-sflib: *) (* https://github.com/snu-sf/sflib/blob/master/sflib.v *) (* *) (* *********************************************************************) From 2bd4c5aed431c3b7b049ea646cde8ecbfefc431a Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 20 Sep 2023 22:20:38 +0900 Subject: [PATCH 149/174] vstore semantics strengthened; WIP --- common/Events.v | 11 + security/Backtranslation.v | 668 +++++++++---------------------------- security/BtInfoAsm.v | 15 +- 3 files changed, 179 insertions(+), 515 deletions(-) diff --git a/common/Events.v b/common/Events.v index 74e55d856d..8f680b7a19 100644 --- a/common/Events.v +++ b/common/Events.v @@ -2193,6 +2193,14 @@ Section VISIBLE. | _ => 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 @@ -2204,6 +2212,7 @@ Section VISIBLE. 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. @@ -2226,6 +2235,8 @@ Section VISIBLE. | 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. diff --git a/security/Backtranslation.v b/security/Backtranslation.v index e1f3b31394..97cad941b3 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -2418,6 +2418,83 @@ Section Backtranslation. exists cst2. split; auto. eapply star_trans. eapply STAR1. eapply STAR2. 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) + : + exists vargs2 vretv2, + (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))) 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. 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. + } + { 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. 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. eapply match_symbs_eventval_match; eauto. + - esplits. + + erewrite eventval_list_match_vals_to_eventvals. 2: eapply H. + eapply list_eventval_to_expr_val_eval; auto. eapply eventval_list_match_transl. + eapply match_senv_eventval_list_match; eauto. + + econs. eapply eventval_list_match_transl_val. 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. eapply eventval_match_sem_cast. + erewrite eventval_match_eventval_to_val. + eapply match_senv_eventval_match. eauto. eapply H. eapply match_senv_eventval_match. eauto. eapply H. + + econs. erewrite eventval_match_eventval_to_val. + eapply match_senv_eventval_match. eauto. eapply H. eapply match_senv_eventval_match. eauto. eapply H. + 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 ir_to_clight_step @@ -2984,74 +3061,24 @@ Section Backtranslation. instantiate (1:=Sreturn None). intros (m_cu & CNT_CUR_STORE & CUR_SWITCH_STAR). rename MEM into DELTA. move ECCASES after CUR_SWITCH_STAR. - desH ECCASES; cycle 1. - { subst d. unfold mem_delta_apply_wf in DELTA. simpl in DELTA. inversion DELTA; clear DELTA. subst m1'. + 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. + } - 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) - : - exists vargs2 vretv2, - (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))) 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. 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. - } - { instantiate (1:=Val.load_result chunk v). - - TODO - - - destruct v; ss. - - destruct chunk; ss; inv H2; ss. - - destruct chunk; ss. all: simpl_expr. - + inv H2. - - esplits. - + erewrite eventval_list_match_vals_to_eventvals. 2: eapply H. - eapply list_eventval_to_expr_val_eval; auto. eapply eventval_list_match_transl. - eapply match_senv_eventval_list_match; eauto. - + econs. eapply eventval_list_match_transl_val. 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. eapply eventval_match_sem_cast. - erewrite eventval_match_eventval_to_val. - eapply match_senv_eventval_match. eauto. eapply H. eapply match_senv_eventval_match. eauto. eapply H. - + econs. erewrite eventval_match_eventval_to_val. - eapply match_senv_eventval_match. eauto. eapply H. eapply match_senv_eventval_match. eauto. eapply H. - Qed. + desH ECCASES; cycle 1. + { 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 (vargs2 & vretv2 & EVALS & EXT2). eapply star_cut_middle. exists E0. eexists. split. { unfold wf_c_stmt in WFC2. specialize (WFC2 _ CNTS_CUR). subst stmt. @@ -3072,458 +3099,79 @@ Section Backtranslation. - eapply FSN_C. - econs 2. ss. } - { TODO - - Lemma match_symbs_extcall_known_obs - ge1 ge2 - (MS: match_symbs ge1 ge2) - ef m1 vargs tr vretv m2 - (EK: external_call_known_observables ef ge1 m1 vargs tr vretv m2) - : - external_call_known_observables ef ge2 m1 vargs tr vretv m2. - Proof. - pose proof MS as MS0. destruct MS as (MS1 & MS2 & MS3). - unfold external_call_known_observables in *. des_ifs; ss; des. all: splits; [inv EK; clarify | auto]. - - inv H; clarify. econs. econs; auto. rewrite MS3; auto. eapply match_symbs_eventval_match; eauto. - - inv H; clarify. econs. econs; auto. rewrite MS3; auto. eapply match_symbs_eventval_match; eauto. - - econs; eauto. eapply match_symbs_eventval_list_match; eauto. - - econs; eauto. eapply match_symbs_eventval_match; eauto. - Qed. - external_call ef ge vargs m t vres m' -> - - (* Lemma match_symbs_vals_to_eventvals *) - (* ge1 ge2 *) - (* (MS: match_symbs ge1 ge2) *) - (* varg *) - (* : *) - (* val_to_eventval ge1 varg = val_to_eventval ge2 varg. *) - (* Proof. *) - (* destruct varg; ss. destruct MS as (MS1 & MS2 & MS3). unfold senv_invert_symbol_total. des_ifs. *) - (* - apply Senv.invert_find_symbol in Heq, Heq0. apply MS2 in Heq. apply Senv.find_invert_symbol in Heq, Heq0. *) - (* rewrite Heq in Heq0; clarify. *) - (* - apply Senv.invert_find_symbol in Heq. apply MS2 in Heq. apply Senv.find_invert_symbol in Heq. clarify. *) - (* - *) - (* - *) - - (* Lemma match_symbs_vals_to_eventvals *) - (* ge1 ge2 *) - (* (MS: match_symbs ge1 ge2) *) - (* vargs *) - (* : *) - (* vals_to_eventvals ge1 vargs = vals_to_eventvals ge2 vargs. *) - - Lemma extcall_known_observables_eval_args - (ge0: Senv.t) (ge: genv) - (MS: match_symbs ge0 ge) - ef m1 vargs tr vretv m2 - (EK: external_call_known_observables ef ge0 m1 vargs tr vretv m2) - e cp le m' - (WFE : wf_env ge e) - : - eval_exprlist ge e cp le m' (list_eventval_to_list_expr (vals_to_eventvals ge0 vargs)) (list_typ_to_typelist (sig_args (ef_sig ef))) vargs. - Proof. - pose proof MS as MS0. destruct MS as (MS1 & MS2 & MS3). - 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. - econs. 3: econs. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. apply sem_cast_ptr. - - inv H; clarify. unfold senv_invert_symbol_total. hexploit Senv.find_invert_symbol; eauto. intros INV. rewrite INV. - econs. - { eapply ptr_of_id_ofs_eval; eauto. } - { rewrite ptr_of_id_ofs_typeof. apply sem_cast_ptr. } - econs. 3: econs. - { eapply val_load_result_aux in H2. eapply eventval_to_expr_val_eval; auto. - - - - - inv ENV; inv EV. pose proof SEM as SEM0. inv SEM. inv H5. econstructor 2. - { apply val_load_result_aux in H10. - eapply step_builtin. - - econstructor; eauto. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. eapply sem_cast_ptr. - econstructor; eauto. 3: econstructor. eapply eventval_to_expr_val_eval; auto. eapply eventval_match_wf_eventval_ge; eauto. - eapply eventval_match_sem_cast. erewrite eventval_match_eventval_to_val; eauto. - - simpl. econstructor. econstructor 1; eauto. - } - simpl. econstructor 1. all: eauto. - - - - } - - - - 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. } - } + { 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. } } - - - - - eapply step_call; simpl. - - ss. - - ec - - - - - - - - - - } - clear BOUND2 CUR_SWITCH_STAR. - - - 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_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_C in H. clarify. } - subst b0. assert (f0 = f). - { rewrite FINDF_C_CUR in H0. clarify. } - subst f0. 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. - admit. (*ez*) - * 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. assert (fd_cur = AST.Internal f_i_cur). - { rewrite FINDFD in FINDF_I_CUR; clarify. } - subst fd_cur. eapply sem_cast_proj_rettype. ss. 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 FINDF_I_CUR. 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. - assert (fd_cur = AST.Internal f_i_cur). - { rewrite FINDFD in FINDF_I_CUR; clarify. } - subst fd_cur. ss. erewrite proj_rettype_to_type_rettype_of_type_eq. 2: eapply H0. - eapply match_senv_eventval_match. 2: eapply H0. destruct MS0 as (MS0 & _). auto. - } - 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. - - - - - - - TODO - - - - 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 ECCASES after DELTA. desH ECCASES; cycle 1. - { subst d. unfold mem_delta_apply_wf in *. ss. inv DELTA. - - TODO - - - 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. + 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_C in H. clarify. } + subst b. assert (f0 = f). + { rewrite FINDF_C_CUR in H0. clarify. } + subst f0. ss. 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. + admit. (*ez*) + * 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. + } } - 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 (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_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_C in H. clarify. } - subst b0. assert (f0 = f). - { rewrite FINDF_C_CUR in H0. clarify. } - subst f0. 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. - admit. (*ez*) - * 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. - } - 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. assert (fd_cur = AST.Internal f_i_cur). - { rewrite FINDFD in FINDF_I_CUR; clarify. } - subst fd_cur. eapply sem_cast_proj_rettype. ss. 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 FINDF_I_CUR. 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. - assert (fd_cur = AST.Internal f_i_cur). - { rewrite FINDFD in FINDF_I_CUR; clarify. } - subst fd_cur. ss. erewrite proj_rettype_to_type_rettype_of_type_eq. 2: eapply H0. - eapply match_senv_eventval_match. 2: eapply H0. destruct MS0 as (MS0 & _). auto. - } - 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. TODO - diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index 0e273af2a4..d5b97c09e3 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -1156,7 +1156,7 @@ Section PROOF. { 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]. inv EXTCALL. inv H; simpl in *; clarify. esplits; eauto. + { 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. } @@ -1262,7 +1262,7 @@ Section PROOF. { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. } splits; auto. } - { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. + { 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. @@ -1272,7 +1272,10 @@ Section PROOF. { 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. econs; eauto. econs. econs; 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. } @@ -1429,7 +1432,7 @@ Section PROOF. { simpl. unfold senv_invert_symbol_total. erewrite Senv.find_invert_symbol; eauto. } splits; auto. } - { destruct ECKO as [_ OBS]. inv EXTCALL. inv H; simpl in *; clarify. + { 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. @@ -1438,7 +1441,9 @@ Section PROOF. { 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. econs; eauto. econs. econs; 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. } From 94d52bda821ded81d1ff92ca8b76d39fd916c0cb Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 21 Sep 2023 14:25:13 +0900 Subject: [PATCH 150/174] WIP --- security/Backtranslation.v | 382 +++++++++++++++++++++++++++++++++++++ 1 file changed, 382 insertions(+) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 97cad941b3..e57f8419f3 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -2523,6 +2523,7 @@ Section Backtranslation. destruct MS as (MS0 & MS1 & MS2 & MS3 & MS4 & MS5 & MCNTS). move STEP after WFC4. inv STEP. + (** Case 1: Cross Call *) - assert (id = id_cur). { unfold match_cur_fun in MS2. des. rewrite MS7 in IDCUR. clarify. } subst id. @@ -2803,6 +2804,7 @@ Section Backtranslation. } traceEq. + (** Case 2: Cross Return *) - assert (id = id_cur). { unfold match_cur_fun in MS2. des. rewrite MS7 in IDCUR. clarify. } subst id. rename f_next into fi_next. @@ -3027,6 +3029,7 @@ Section Backtranslation. } all: traceEq. traceEq. + (** Case 3: Internal-External Call *) - assert (id = id_cur). { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } subst id. rename id0 into id_next. @@ -3077,6 +3080,7 @@ Section Backtranslation. 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 (vargs2 & vretv2 & EVALS & EXT2). eapply star_cut_middle. exists E0. @@ -3168,6 +3172,384 @@ Section Backtranslation. } } } + (* 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). + + 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. + + 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. + } + { + 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 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. + + eapply match_symbs_vals_public_eval_to_vargs; auto. + destruct MS0 as (MS0 & _). auto. + + 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. + + 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. + } + + 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. + 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 H1; eauto. } + + TODO + +mem_valid_access_wunchanged_on: + forall (m : mem) (ch : memory_chunk) (b : block) (ofs : Z) (p : permission) + (cp : option compartment), + Mem.valid_access m ch b ofs p cp -> + forall (P : block -> Z -> Prop) (m' : mem), + wunchanged_on P m m' -> (forall ofs' : Z, P b ofs') -> Mem.valid_access m' ch b ofs p cp + + 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_C in H. clarify. } + subst b. assert (f0 = f). + { rewrite FINDF_C_CUR in H0. clarify. } + subst f0. ss. 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. + admit. (*ez*) + * 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 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. + } + } + } + + + + + + + + + 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. } + + + + + + + + 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_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_C in H. clarify. } + subst b0. assert (f0 = f). + { rewrite FINDF_C_CUR in H0. clarify. } + subst f0. 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. + admit. (*ez*) + * 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. assert (fd_cur = AST.Internal f_i_cur). + { rewrite FINDFD in FINDF_I_CUR; clarify. } + subst fd_cur. eapply sem_cast_proj_rettype. ss. 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 FINDF_I_CUR. 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. + assert (fd_cur = AST.Internal f_i_cur). + { rewrite FINDFD in FINDF_I_CUR; clarify. } + subst fd_cur. ss. erewrite proj_rettype_to_type_rettype_of_type_eq. 2: eapply H0. + eapply match_senv_eventval_match. 2: eapply H0. destruct MS0 as (MS0 & _). auto. + } + 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. From 6b9f44352eacc52eafa35f026d55e87f6cff2b42 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 21 Sep 2023 18:13:04 +0900 Subject: [PATCH 151/174] WIP --- security/Backtranslation.v | 195 ++++++++++++++++++++++++++++++++----- 1 file changed, 170 insertions(+), 25 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index e57f8419f3..c4a94fd87c 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -3339,27 +3339,43 @@ Section Backtranslation. econs 1. all: ss. traceEq. } + clear CUR_SWITCH_STAR BOUND2. 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. + 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 H1; eauto. } exists b0. splits; auto. + move MCNTS after COMP_SAME. - 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 H1; eauto. } - - TODO - -mem_valid_access_wunchanged_on: - forall (m : mem) (ch : memory_chunk) (b : block) (ofs : Z) (p : permission) - (cp : option compartment), - Mem.valid_access m ch b ofs p cp -> - forall (P : block -> Z -> Prop) (m' : mem), - wunchanged_on P m m' -> (forall ofs' : Z, P b ofs') -> Mem.valid_access m' ch b ofs p cp - - eapply mem_valid_access_wunchanged_on. eapply WFC7. - eapply store_wunchanged_on. eapply CNT_CUR_STORE. instantiate (1:= fun _ _ => True). ss. + + 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. + + 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. } @@ -3369,18 +3385,147 @@ mem_valid_access_wunchanged_on: { rewrite FIND_CUR_C in H. clarify. } subst b. assert (f0 = f). { rewrite FINDF_C_CUR in H0. clarify. } - subst f0. ss. 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. - admit. (*ez*) - * 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. + subst f0. 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: 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. + admit. (*ez*) } - 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 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. + 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. + + 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. + 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_free_preserves_2 + 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_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. + 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_2. 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_2; eauto. } + eauto. + Qed. + + Lemma wunchanged_on_free_list_preserves_2 + 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_2; eauto. + Qed. + + hexploit wunchanged_on_exists_mem_free_list_2. eapply FREEENV. eapply UCH7. ss. + intros (m_c' & FREE2). esplits. eapply FREE2. + + + + TODO + + +wf_c_cont_wunchanged_on: + forall (ge : genv) (m : mem) (k : cont), + wf_c_cont ge m k -> forall m' : mem, wunchanged_on (fun (b : block) (_ : Z) => Mem.valid_block m b) m m' -> wf_c_cont ge m' k + +wunchanged_on_exists_mem_free_list: + forall m m' : mem, + wunchanged_on (fun (b : block) (_ : Z) => Mem.valid_block m b) m m' -> + forall (l : list (block * Z * Z)) (cp : compartment) (m_f : mem), + Mem.free_list m l cp = Some m_f -> exists m_f' : mem, Mem.free_list m' l cp = Some m_f' + +mem_free_list_wunchanged_on_2: + forall (l : list (block * Z * Z)) (m : mem) (cp : compartment) (m' : mem), + Mem.free_list m l cp = Some m' -> + wunchanged_on (fun (b : block) (_ : Z) => ~ In b (map (fun x : block * Z * Z => fst (fst x)) l)) m m' + + 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. From af25dd1a94f7fc90dcb224f8121632c7932005fd Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 22 Sep 2023 11:32:00 +0900 Subject: [PATCH 152/174] WIP --- security/Backtranslation.v | 717 ++++++++++++++++--------------------- 1 file changed, 307 insertions(+), 410 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index c4a94fd87c..7a99c458b4 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -2495,8 +2495,273 @@ Section Backtranslation. 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 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 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 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 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. + + (* WIP *) Lemma ir_to_clight_step (ge_i: Asm.genv) (ge_c: Clight.genv) (WFGE: wf_ge ge_i) @@ -3172,21 +3437,11 @@ Section Backtranslation. } } } + (* 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). - - 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. - hexploit mem_delta_apply_establish_inject_preprocess2. eapply MM0. eapply CNT_CUR_STORE. 2: eapply MM1. 2: eapply MM2. 2: eapply DELTA. @@ -3201,7 +3456,6 @@ Section Backtranslation. { 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. } @@ -3226,103 +3480,8 @@ Section Backtranslation. - eapply FSN_C. - econs 2. ss. } - { - 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 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. - - eapply match_symbs_vals_public_eval_to_vargs; auto. + { eapply match_symbs_vals_public_eval_to_vargs; auto. destruct MS0 as (MS0 & _). auto. - - 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. - eapply extcall_unkowns_vals_public; eauto. } { eapply FIND_F_C. } @@ -3340,37 +3499,26 @@ Section Backtranslation. } 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. - 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 H1; eauto. } exists b0. splits; auto. + move MCNTS after COMP_SAME. - - 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. - 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. @@ -3411,291 +3559,40 @@ Section Backtranslation. } - move FREEENV after COMP_SAME. move WFC1 after FREEENV. move WFC4 after FREEENV. - 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. - - 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. - 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_free_preserves_2 - 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_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. - 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_2. 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_2; eauto. } - eauto. - Qed. - - Lemma wunchanged_on_free_list_preserves_2 - 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_2; eauto. - Qed. - - hexploit wunchanged_on_exists_mem_free_list_2. eapply FREEENV. eapply UCH7. ss. + hexploit wunchanged_on_exists_mem_free_list_2. eapply FREEENV. + instantiate (2:=ge_c). eapply UCH7. ss. intros (m_c' & FREE2). esplits. eapply FREE2. - - - - TODO - - -wf_c_cont_wunchanged_on: - forall (ge : genv) (m : mem) (k : cont), - wf_c_cont ge m k -> forall m' : mem, wunchanged_on (fun (b : block) (_ : Z) => Mem.valid_block m b) m m' -> wf_c_cont ge m' k - -wunchanged_on_exists_mem_free_list: - forall m m' : mem, - wunchanged_on (fun (b : block) (_ : Z) => Mem.valid_block m b) m m' -> - forall (l : list (block * Z * Z)) (cp : compartment) (m_f : mem), - Mem.free_list m l cp = Some m_f -> exists m_f' : mem, Mem.free_list m' l cp = Some m_f' - -mem_free_list_wunchanged_on_2: - forall (l : list (block * Z * Z)) (m : mem) (cp : compartment) (m' : mem), - Mem.free_list m l cp = Some m' -> - wunchanged_on (fun (b : block) (_ : Z) => ~ In b (map (fun x : block * Z * Z => fst (fst x)) l)) m m' - - 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 WFNB after COMP_SAME. unfold wf_c_nb in *. erewrite Mem.nextblock_store. eapply WFNB. eapply CNT_CUR_STORE. + 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 k_c. splits; auto. + { ss. exists j2. 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. + { 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. } - } - } - - - - - - - - - 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. } - - - - - - - - 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_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_C in H. clarify. } - subst b0. assert (f0 = f). - { rewrite FINDF_C_CUR in H0. clarify. } - subst f0. 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. - admit. (*ez*) - * 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. + { 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. } - 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. assert (fd_cur = AST.Internal f_i_cur). - { rewrite FINDFD in FINDF_I_CUR; clarify. } - subst fd_cur. eapply sem_cast_proj_rettype. ss. 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 FINDF_I_CUR. 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. - assert (fd_cur = AST.Internal f_i_cur). - { rewrite FINDFD in FINDF_I_CUR; clarify. } - subst fd_cur. ss. erewrite proj_rettype_to_type_rettype_of_type_eq. 2: eapply H0. - eapply match_senv_eventval_match. 2: eapply H0. destruct MS0 as (MS0 & _). auto. - } - 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. + 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. + } + } } - all: traceEq. traceEq. + (** Case 4: Builtins *) + - TODO From 78f682cabce9ba58a330cbae9e5932ec97f77272 Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 22 Sep 2023 12:39:37 +0900 Subject: [PATCH 153/174] WIP --- security/Backtranslation.v | 294 ++++++++++++++++++++++++++++++++++++- security/BtInfoAsm.v | 16 ++ 2 files changed, 309 insertions(+), 1 deletion(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 7a99c458b4..cf554468a9 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -3592,7 +3592,299 @@ Section Backtranslation. } (** Case 4: Builtins *) - - + - assert (id = id_cur). + { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } + subst id. + + set (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr) as ttr in *. + 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)). + { destruct MS2 as (MFUN0 & MFUN1). auto. } + + exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } + destruct WF_CNT_CUR as (CNT_CUR_NPUB & cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). + + 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). + 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. } + + 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 (COMP_SAME: comp_of f = comp_of ef). + { + TODO + + rewrite COMP_F_C. unfold Genv.find_comp. rewrite FIND_F_C. ss. } + 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. + } + + 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 (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_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. + 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_C in H. clarify. } + subst b. assert (f0 = f). + { rewrite FINDF_C_CUR in H0. clarify. } + subst f0. ss. 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. + admit. (*ez*) + * 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_C in H. clarify. } + subst b. assert (f0 = f). + { rewrite FINDF_C_CUR in H0. clarify. } + subst f0. 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: 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. + admit. (*ez*) + } + * 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. + } + } + } TODO diff --git a/security/BtInfoAsm.v b/security/BtInfoAsm.v index d5b97c09e3..1c7dba6088 100644 --- a/security/BtInfoAsm.v +++ b/security/BtInfoAsm.v @@ -278,6 +278,7 @@ Section IR. 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 @@ -1417,6 +1418,9 @@ Section PROOF. 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. @@ -1426,6 +1430,9 @@ Section PROOF. 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. } @@ -1437,6 +1444,9 @@ Section PROOF. 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. @@ -1457,6 +1467,9 @@ Section PROOF. 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. } @@ -1467,6 +1480,9 @@ Section PROOF. 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. } From b0452b2531beb87da6491bf74373968aa4aadcf4 Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 22 Sep 2023 15:16:29 +0900 Subject: [PATCH 154/174] WIP --- security/Backtranslation.v | 216 +++++++++++++++++++++++++------------ 1 file changed, 148 insertions(+), 68 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index cf554468a9..9d13e46846 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -2486,6 +2486,87 @@ Section Backtranslation. eapply match_senv_eventval_match. eauto. eapply H. eapply match_senv_eventval_match. eauto. eapply H. 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') @@ -2530,6 +2611,29 @@ Section Backtranslation. + 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) @@ -2588,6 +2692,21 @@ Section Backtranslation. 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 @@ -3625,67 +3744,43 @@ Section Backtranslation. 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 (COMP_SAME: comp_of f = comp_of ef). - { - TODO - - rewrite COMP_F_C. unfold Genv.find_comp. rewrite FIND_F_C. ss. } - 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. - } + { rewrite ALLOWED. apply CP_CUR. } + rename MEM into DELTA. move ECCASES after CUR_SWITCH_STAR. desH ECCASES; cycle 1. - (* Case 3-1: observable defined external calls *) + (* 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. eapply MS0. eapply ECCASES. eauto. intros (vargs2 & vretv2 & EVALS & EXT2). + 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_call ge_i ge_c) in CUR_SWITCH_STAR. + 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_call. eapply star_trans. eapply code_mem_delta_correct. auto. + unfold code_bundle_builtin. 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. } + econs 1. ss. } clear BOUND2 CUR_SWITCH_STAR. - 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. + 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. - { ss. splits; auto. + { 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. @@ -3733,7 +3828,7 @@ Section Backtranslation. } } - (* Case 3-2: observables unknown external calls *) + (* 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). @@ -3751,46 +3846,28 @@ Section Backtranslation. { 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_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_call. eapply star_trans. eapply code_mem_delta_correct. auto. + 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_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. + 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. } - { 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. + { 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. @@ -3886,6 +3963,9 @@ Section Backtranslation. } } + (** Case 5: Cross Call External 1 *) + - + TODO From f86cd702df3c5bb2b04f0f85890b5c36519007c7 Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 22 Sep 2023 16:42:27 +0900 Subject: [PATCH 155/174] WIP --- security/Backtranslation.v | 374 ++++++++++++++++++++++++++++++++++++- 1 file changed, 372 insertions(+), 2 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 9d13e46846..a1f29db2b0 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1192,6 +1192,29 @@ Section Backtranslation. eapply FO; eauto. Qed. + TODO + + (* 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. *) + (* unfold mem_delta_apply_wf in APPD. rewrite mem_delta_apply_wf_get_wf_mem_delta. *) + (* eapply mem_delta_apply_establish_inject_preprocess; 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. *) + End PROOF. @@ -2879,6 +2902,353 @@ Section Backtranslation. 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 : 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) (f : function), + Genv.find_symbol ge_c id = Some b -> + Genv.find_funct_ptr ge_c b = Some (Internal f) -> + exists cnt : ident, + cnts ! id = Some cnt /\ + wf_counter ge_c m_c (comp_of f) (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 = [])) + : + exists cnt_cur cnt_cur_b, + (cnts ! id_cur = Some cnt_cur /\ Senv.find_symbol ge_c cnt_cur = Some cnt_cur_b) /\ + 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) + (unbundle (id_cur, Bundle_call tr id0 evargs (ef_sig ef) d)) + (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. + + 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_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)). + { destruct MS2 as (MFUN0 & MFUN1). auto. } + + exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } + + 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). + 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. } + + 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). + + TODO + 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')))). + { desH DELTA_CASES. + + 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 (ENV_NINJ: not_inj_blks (meminj_public 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. *) + (* unfold meminj_public. des_ifs. exfalso. simpl in Heq. *) + (* move MS1 after Heq0. destruct MS1 as (MM1 & MM2 & MM3). *) + (* erewrite match_symbs_meminj_public in MEMINJ_CNT. *) + (* 2:{ destruct MS0 as (MS0 & _). apply MS0. } *) + (* hexploit Mem.valid_block_inject_2. 2: eapply MEMINJ_CNT. *) + (* { unfold meminj_public. setoid_rewrite Heq. rewrite Heq0. eauto. } *) + (* eapply alloc_variables_one_fresh_block. eapply ENV_ALLOC. *) + (* { rewrite app_nil_r. eapply MP1. eauto. } *) + (* ss. eapply H0. *) + (* } *) + + assert (WFC_NEXT: wf_c_state 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. + + destruct (Pos.eq_dec id id_cur). + * subst id. clarify. ss. rewrite FIND_CNT_CUR in WFC6. clarify. + erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. + 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. admit. (*ez*) } + erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. + 2:{ admit. (* same ez *) } + 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. + admit. (*ez*) + * ss. erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. + 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. admit. (*ez*) } + erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. + 2:{ admit. (* same ez *) } + 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. + + (* WIP *) Lemma ir_to_clight_step @@ -3123,9 +3493,9 @@ Section Backtranslation. - 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. @@ -3965,7 +4335,7 @@ Section Backtranslation. (** Case 5: Cross Call External 1 *) - - + TODO From bbbdd9f50f41c92c4f68a8fdb19e6d6f1f06c5bd Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 22 Sep 2023 16:59:40 +0900 Subject: [PATCH 156/174] WIP --- security/Backtranslation.v | 89 +++++++++++++++++++++----------------- security/MemoryDelta.v | 48 ++++++++++++++++++++ 2 files changed, 98 insertions(+), 39 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index a1f29db2b0..030559267e 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1171,7 +1171,7 @@ Section Backtranslation. eapply FO; eauto. Qed. - Lemma mem_delta_apply_establish_inject_preprocess2 + 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'' @@ -1181,39 +1181,33 @@ Section Backtranslation. (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'. + 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; eauto. + eapply mem_delta_apply_establish_inject_preprocess_gen; 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. - TODO - - (* 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. *) - (* unfold mem_delta_apply_wf in APPD. rewrite mem_delta_apply_wf_get_wf_mem_delta. *) - (* eapply mem_delta_apply_establish_inject_preprocess; 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_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. @@ -2901,6 +2895,16 @@ Section Backtranslation. 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 ir_to_clight_step_cce_1 (ge_i: Asm.genv) (ge_c: genv) @@ -3008,25 +3012,32 @@ Section Backtranslation. instantiate (1:=Sreturn None). intros (m_cu & CNT_CUR_STORE & CUR_SWITCH_STAR). - TODO 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')))). - { desH DELTA_CASES. - - 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. + { 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. unfold meminj_public in H. des_ifs. apply Senv.find_invert_symbol in FIND_CNT_CUR. - rewrite FIND_CNT_CUR in Heq. clarify. + ii. eapply meminj_public_not_public_not_mapped. 3: apply H. 2: eauto. auto. } - apply INJINCR. apply NALLOC. apply DELTA. apply PUB. + apply INJINCR. apply NALLOC. apply DELTA. intros (m_c' & DELTA' & INJ'). exists m_c'. splits; auto. - rewrite CP_CUR. auto. + rewrite CP_CUR. auto. i. apply INJ'. apply public_first_order_meminj_first_order; auto. } - des. rename DELTA_C0 into MEMINJ_CNT. + 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. + } + + TODO + + + 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. diff --git a/security/MemoryDelta.v b/security/MemoryDelta.v index 54c5e49e1a..bcd6b4bbf2 100644 --- a/security/MemoryDelta.v +++ b/security/MemoryDelta.v @@ -1141,4 +1141,52 @@ Section PROOFS. 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. From 042a87795ddcb99ea17212fc2a23c283102d5da9 Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 22 Sep 2023 17:46:51 +0900 Subject: [PATCH 157/174] WIP --- security/Backtranslation.v | 240 +++++++++---------------------------- 1 file changed, 55 insertions(+), 185 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 030559267e..9e4bc67ff2 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -1664,6 +1664,34 @@ Section Backtranslation. } 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) @@ -2905,6 +2933,13 @@ Section Backtranslation. 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. Lemma ir_to_clight_step_cce_1 (ge_i: Asm.genv) (ge_c: genv) @@ -2993,7 +3028,10 @@ Section Backtranslation. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } + { rewrite map_length. eapply Z.le_lt_trans. 2: eauto. unfold get_id_tr. + apply inj_le. + + admit. (* ez *) } 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. @@ -3034,185 +3072,20 @@ Section Backtranslation. - i. split; auto. } - TODO - - - - 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 (ENV_NINJ: not_inj_blks (meminj_public 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. *) - (* unfold meminj_public. des_ifs. exfalso. simpl in Heq. *) - (* move MS1 after Heq0. destruct MS1 as (MM1 & MM2 & MM3). *) - (* erewrite match_symbs_meminj_public in MEMINJ_CNT. *) - (* 2:{ destruct MS0 as (MS0 & _). apply MS0. } *) - (* hexploit Mem.valid_block_inject_2. 2: eapply MEMINJ_CNT. *) - (* { unfold meminj_public. setoid_rewrite Heq. rewrite Heq0. eauto. } *) - (* eapply alloc_variables_one_fresh_block. eapply ENV_ALLOC. *) - (* { rewrite app_nil_r. eapply MP1. eauto. } *) - (* ss. eapply H0. *) - (* } *) - - assert (WFC_NEXT: wf_c_state 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. - + destruct (Pos.eq_dec id id_cur). - * subst id. clarify. ss. rewrite FIND_CNT_CUR in WFC6. clarify. - erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. - 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. admit. (*ez*) } - erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. - 2:{ admit. (* same ez *) } - 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. - admit. (*ez*) - * ss. erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. - 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. admit. (*ez*) } - erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. - 2:{ admit. (* same ez *) } - 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. + 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. - destruct MS0 as (MSYMB & _). auto. } - 2: ss. 2,3: destruct MS0 as (MSENV & _); apply MSENV. + { 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 fi_next)). - { unfold Genv.find_comp. apply Genv.find_funct_ptr_iff in FINDF_C. setoid_rewrite FINDF_C. subst f_next. ss. } + 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. @@ -3233,17 +3106,17 @@ Section Backtranslation. 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. } + { ss. } { 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. } + 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 MS_NEXT. move TR after NPTR. i. + { 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 MS_NEXT. instantiate (1:=tr). inv TR. + { move TR after EVARGS. instantiate (1:=tr). inv TR. setoid_rewrite CP_CUR. rewrite CP_NEXT. econs 2. { rewrite <- H. ss. } @@ -3252,13 +3125,10 @@ Section Backtranslation. { 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. } - } + { rewrite EVARGS. subst kc_next. econs 1. } traceEq. - + Admitted. + (* WIP *) From d92d9de0ba98b5b677c7141a659de1166abfb71f Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 22 Sep 2023 18:31:42 +0900 Subject: [PATCH 158/174] refactor files --- Makefile | 2 +- security/Backtranslation.v | 7816 ++++++++++++++----------------- security/BacktranslationAux.v | 2015 ++++++++ security/BacktranslationProof.v | 1586 +++++++ 4 files changed, 7074 insertions(+), 4345 deletions(-) create mode 100644 security/BacktranslationAux.v create mode 100644 security/BacktranslationProof.v diff --git a/Makefile b/Makefile index eb98c8c0c5..31e5fa662a 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 Tactics.v MemoryWeak.v MemoryDelta.v BtInfoAsm.v BtBasics.v Backtranslation.v +SECURITY=RSC.v Split.v Blame.v Recomposition.v Tactics.v MemoryWeak.v MemoryDelta.v BtBasics.v BtInfoAsm.v Backtranslation.v BacktranslationAux.v BacktranslationProof.v # Parser diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 9e4bc67ff2..089d53962c 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -9,7 +9,7 @@ Require Import riscV.Asm. Require Import BtBasics BtInfoAsm MemoryDelta MemoryWeak. Require Import Ctypes Clight. -Section Backtranslation. + Ltac simpl_expr := repeat (match goal with @@ -532,204 +532,204 @@ Section Backtranslation. End CODE. - 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. + (* Section CODEPROOFS. *) - 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 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 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_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. *) - 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. + (* 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 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 val_cases v: (val_is_int v) \/ (val_is_not_int v). *) + (* Proof. destruct v; ss; auto. 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 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 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. + (* 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. *) - End CODEPROOFS. + (* 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 GEN. @@ -942,4211 +942,3339 @@ Section Backtranslation. End GENPROOFS. - 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. + (* Section GENV. *) - 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. + (* 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. *) - 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. + (* Definition match_symbs (ge1 ge2: Senv.t) := symbs_public ge1 ge2 /\ symbs_find ge1 ge2 /\ symbs_volatile ge1 ge2. *) - 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_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_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_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_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_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_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_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_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_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_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_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_symbols_inject - ge1 ge2 - (MSYMB: match_symbs ge1 ge2) - : - symbols_inject (meminj_public ge1) ge1 ge2. - Proof. - Admitted. + (* 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. *) - End GENV. + (* 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. *) - Section PROOF. + (* Lemma match_symbs_symbols_inject *) + (* ge1 ge2 *) + (* (MSYMB: match_symbs ge1 ge2) *) + (* : *) + (* symbols_inject (meminj_public ge1) ge1 ge2. *) + (* Proof. *) + (* Admitted. *) - 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. + (* End GENV. *) - 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. + (* Section PROOF. *) - 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 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 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_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 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 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 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. + (* 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. + (* End PROOF. *) - Section INVS. + (* Section INVS. *) - Definition cnt_ids := PTree.t ident. + (* 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_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: 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 (f: function), - (Genv.find_symbol ge id = Some b) -> (Genv.find_funct_ptr ge b = Some (Internal f)) -> - (exists cnt, (cnts ! id = Some cnt) /\ (wf_counter ge m (comp_of f) (length (get_id_tr tr id)) cnt))). + (* Definition wf_counters (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 (f: function), *) + (* (Genv.find_symbol ge id = Some b) -> (Genv.find_funct_ptr ge b = Some (Internal f)) -> *) + (* (exists cnt, (cnts ! id = Some cnt) /\ (wf_counter ge m (comp_of f) (length (get_id_tr tr id)) cnt))). *) - Definition not_global_blks (ge: Senv.t) (ebs: list block) := - Forall (fun b => Senv.invert_symbol ge b = None) ebs. + (* 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 blocks_of_env2 ge e : list block := (map (fun x => fst (fst x)) (blocks_of_env ge e)). *) - 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: 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 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)) - (* (wf_env ge e /\ wf_env_unique_blocks e /\ wf_env_mem ge (comp_of f) e m_c) *) - | _ => False - end. + (* 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: 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 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)) *) + (* (* (wf_env ge e /\ wf_env_unique_blocks e /\ wf_env_mem ge (comp_of f) e m_c) *) *) + (* | _ => False *) + (* end. *) + + (* 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. *) + + (* 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). *) + (* (* /\ (public_rev_perm m_i m_c). *) *) + + (* 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 not_inj_blks (j: meminj) (ebs: list block) := - Forall (fun b => j b = None) ebs. + (* 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). *) - 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 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. *) - Definition eq_policy (ge1: Asm.genv) (ge2: genv) := - Genv.genv_policy ge1 = Genv.genv_policy ge2. - Definition match_genv (ge: Asm.genv) (ge': genv) := - (match_symbs ge ge') /\ (eq_policy ge ge'). + (* Definition meminj_same_block (j : meminj) := *) + (* forall b1 b2 del, j b1 = Some (b2, del) -> b1 = b2. *) - 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). - (* /\ (public_rev_perm m_i m_c). *) - 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). + (* Section PROOF. *) - 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. + (* (* 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. *) - 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. + (* 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. *) - End INVS. + (* 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. *) - Definition meminj_same_block (j : meminj) := - forall b1 b2 del, j b1 = Some (b2, del) -> b1 = b2. + (* 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. *) - Section PROOF. + (* 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. *) - (* 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 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 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 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 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 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 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 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 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 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 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 star_cut_middle *) + (* stepk 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_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_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 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) *) + (* : *) + (* exists vargs2 vretv2, *) + (* (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))) 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. 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. *) + (* } *) + (* { 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. 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. eapply match_symbs_eventval_match; eauto. *) + (* - esplits. *) + (* + erewrite eventval_list_match_vals_to_eventvals. 2: eapply H. *) + (* eapply list_eventval_to_expr_val_eval; auto. eapply eventval_list_match_transl. *) + (* eapply match_senv_eventval_list_match; eauto. *) + (* + econs. eapply eventval_list_match_transl_val. 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. eapply eventval_match_sem_cast. *) + (* erewrite eventval_match_eventval_to_val. *) + (* eapply match_senv_eventval_match. eauto. eapply H. eapply match_senv_eventval_match. eauto. eapply H. *) + (* + econs. erewrite eventval_match_eventval_to_val. *) + (* eapply match_senv_eventval_match. eauto. eapply H. eapply match_senv_eventval_match. eauto. eapply H. *) + (* 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 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 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 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 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. *) + + (* 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 : 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) (f : function), *) + (* Genv.find_symbol ge_c id = Some b -> *) + (* Genv.find_funct_ptr ge_c b = Some (Internal f) -> *) + (* exists cnt : ident, *) + (* cnts ! id = Some cnt /\ *) + (* wf_counter ge_c m_c (comp_of f) (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 = [])) *) + (* : *) + (* exists cnt_cur cnt_cur_b, *) + (* (cnts ! id_cur = Some cnt_cur /\ Senv.find_symbol ge_c cnt_cur = Some cnt_cur_b) /\ *) + (* 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) *) + (* (unbundle (id_cur, Bundle_call tr id0 evargs (ef_sig ef) d)) *) + (* (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. *) + + (* 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_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)). *) + (* { destruct MS2 as (MFUN0 & MFUN1). auto. } *) + + (* exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. *) + + (* admit. (* ez *) } *) + + (* 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). *) + (* 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. } *) + + (* 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. *) + (* Admitted. *) + + + + (* (* WIP *) *) + (* 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_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_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. *) + (* (* REMOVE *) *) + (* Set Nested Proofs Allowed. *) + + (* 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 *) *) + (* - 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. *) + (* 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)). *) + (* { destruct MS2 as (MFUN0 & MFUN1). auto. } *) + + (* exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } *) + (* 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. } *) + + (* 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). *) + (* 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. } *) + + (* 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 (ENV_NINJ: not_inj_blks (meminj_public 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. *) *) + (* (* unfold meminj_public. des_ifs. exfalso. simpl in Heq. *) *) + (* (* move MS1 after Heq0. destruct MS1 as (MM1 & MM2 & MM3). *) *) + (* (* erewrite match_symbs_meminj_public in MEMINJ_CNT. *) *) + (* (* 2:{ destruct MS0 as (MS0 & _). apply MS0. } *) *) + (* (* hexploit Mem.valid_block_inject_2. 2: eapply MEMINJ_CNT. *) *) + (* (* { unfold meminj_public. setoid_rewrite Heq. rewrite Heq0. eauto. } *) *) + (* (* eapply alloc_variables_one_fresh_block. eapply ENV_ALLOC. *) *) + (* (* { rewrite app_nil_r. eapply MP1. eauto. } *) *) + (* (* ss. eapply H0. *) *) + (* (* } *) *) + + (* assert (WFC_NEXT: wf_c_state 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. *) + (* + destruct (Pos.eq_dec id id_cur). *) + (* * subst id. clarify. ss. rewrite FIND_CNT_CUR in WFC6. clarify. *) + (* erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. *) + (* 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. admit. (*ez*) } *) + (* erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. *) + (* 2:{ admit. (* same ez *) } *) + (* 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. *) + (* admit. (*ez*) *) + (* * ss. erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. *) + (* 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. admit. (*ez*) } *) + (* erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. *) + (* 2:{ admit. (* same ez *) } *) + (* 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. *) + + (* (** Case 2: Cross Return *) *) + (* - 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. *) + + (* 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)). *) + (* { destruct MS2 as (MFUN0 & MFUN1). auto. } *) + + (* exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } *) + (* 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. *) + + (* 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). *) + (* 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. } *) + + (* 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_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_C in H. clarify. } *) + (* subst b0. assert (f0 = f). *) + (* { rewrite FINDF_C_CUR in H0. clarify. } *) + (* subst f0. 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. *) + (* admit. (*ez*) *) + (* * 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. assert (fd_cur = AST.Internal f_i_cur). *) + (* { rewrite FINDFD in FINDF_I_CUR; clarify. } *) + (* subst fd_cur. eapply sem_cast_proj_rettype. ss. 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 FINDF_I_CUR. 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. *) + (* assert (fd_cur = AST.Internal f_i_cur). *) + (* { rewrite FINDFD in FINDF_I_CUR; clarify. } *) + (* subst fd_cur. ss. erewrite proj_rettype_to_type_rettype_of_type_eq. 2: eapply H0. *) + (* eapply match_senv_eventval_match. 2: eapply H0. destruct MS0 as (MS0 & _). auto. *) + (* } *) + (* 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. *) + + (* (** Case 3: Internal-External Call *) *) + (* - assert (id = id_cur). *) + (* { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } *) + (* subst id. rename id0 into id_next. *) + + (* 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_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)). *) + (* { destruct MS2 as (MFUN0 & MFUN1). auto. } *) + + (* exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } *) + (* destruct WF_CNT_CUR as (CNT_CUR_NPUB & cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). *) + + (* 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). *) + (* 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. } *) + + (* 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 (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_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_C in H. clarify. } *) + (* subst b. assert (f0 = f). *) + (* { rewrite FINDF_C_CUR in H0. clarify. } *) + (* subst f0. ss. 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. *) + (* admit. (*ez*) *) + (* * 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_C in H. clarify. } *) + (* subst b. assert (f0 = f). *) + (* { rewrite FINDF_C_CUR in H0. clarify. } *) + (* subst f0. 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: 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. *) + (* admit. (*ez*) *) + (* } *) + (* * 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. *) + (* } *) + (* } *) + (* } *) + + (* (** Case 4: Builtins *) *) + (* - assert (id = id_cur). *) + (* { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } *) + (* subst id. *) + + (* set (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr) as ttr in *. *) + (* 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)). *) + (* { destruct MS2 as (MFUN0 & MFUN1). auto. } *) + + (* exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } *) + (* destruct WF_CNT_CUR as (CNT_CUR_NPUB & cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). *) + + (* 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). *) + (* 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. } *) + + (* 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_C in H. clarify. } *) + (* subst b. assert (f0 = f). *) + (* { rewrite FINDF_C_CUR in H0. clarify. } *) + (* subst f0. ss. 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. *) + (* admit. (*ez*) *) + (* * 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_C in H. clarify. } *) + (* subst b. assert (f0 = f). *) + (* { rewrite FINDF_C_CUR in H0. clarify. } *) + (* subst f0. 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: 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. *) + (* admit. (*ez*) *) + (* } *) + (* * 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. *) + (* } *) + (* } *) + (* } *) + + (* (** Case 5: Cross Call External 1 *) *) + (* - *) + + + (* TODO *) + + + + + (* Admitted. *) + + (* Lemma ir_to_clight_aux *) + (* (ge_i: Asm.genv) (ge_c: Clight.genv) *) + (* (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_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) *) + (* (WFCG: wf_c_genv ge_c) *) + (* ist cst *) + (* ttr cnts k id *) + (* (WFC: wf_c_state ge_c [] ttr cnts id cst) *) + (* (MS: match_state ge_i ge_c k ttr cnts 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. 4,5,6,7: eauto. all: eauto. econs 1. ss. econs 1. 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 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 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 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 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 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 star_cut_middle - stepk 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_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_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 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) - : - exists vargs2 vretv2, - (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))) 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. 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. - } - { 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. 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. eapply match_symbs_eventval_match; eauto. - - esplits. - + erewrite eventval_list_match_vals_to_eventvals. 2: eapply H. - eapply list_eventval_to_expr_val_eval; auto. eapply eventval_list_match_transl. - eapply match_senv_eventval_list_match; eauto. - + econs. eapply eventval_list_match_transl_val. 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. eapply eventval_match_sem_cast. - erewrite eventval_match_eventval_to_val. - eapply match_senv_eventval_match. eauto. eapply H. eapply match_senv_eventval_match. eauto. eapply H. - + econs. erewrite eventval_match_eventval_to_val. - eapply match_senv_eventval_match. eauto. eapply H. eapply match_senv_eventval_match. eauto. eapply H. - 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 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 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. - - 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 : 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) (f : function), - Genv.find_symbol ge_c id = Some b -> - Genv.find_funct_ptr ge_c b = Some (Internal f) -> - exists cnt : ident, - cnts ! id = Some cnt /\ - wf_counter ge_c m_c (comp_of f) (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 = [])) - : - exists cnt_cur cnt_cur_b, - (cnts ! id_cur = Some cnt_cur /\ Senv.find_symbol ge_c cnt_cur = Some cnt_cur_b) /\ - 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) - (unbundle (id_cur, Bundle_call tr id0 evargs (ef_sig ef) d)) - (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. - - 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_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)). - { destruct MS2 as (MFUN0 & MFUN1). auto. } - - exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. - - admit. (* ez *) } - - 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). - 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. } - - 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. - Admitted. - - - - (* WIP *) - 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_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_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. - (* REMOVE *) - Set Nested Proofs Allowed. - - 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 *) - - 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. - 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)). - { destruct MS2 as (MFUN0 & MFUN1). auto. } - - exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } - 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. } - - 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). - 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. } - - 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 (ENV_NINJ: not_inj_blks (meminj_public 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. *) - (* unfold meminj_public. des_ifs. exfalso. simpl in Heq. *) - (* move MS1 after Heq0. destruct MS1 as (MM1 & MM2 & MM3). *) - (* erewrite match_symbs_meminj_public in MEMINJ_CNT. *) - (* 2:{ destruct MS0 as (MS0 & _). apply MS0. } *) - (* hexploit Mem.valid_block_inject_2. 2: eapply MEMINJ_CNT. *) - (* { unfold meminj_public. setoid_rewrite Heq. rewrite Heq0. eauto. } *) - (* eapply alloc_variables_one_fresh_block. eapply ENV_ALLOC. *) - (* { rewrite app_nil_r. eapply MP1. eauto. } *) - (* ss. eapply H0. *) - (* } *) - - assert (WFC_NEXT: wf_c_state 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. - + destruct (Pos.eq_dec id id_cur). - * subst id. clarify. ss. rewrite FIND_CNT_CUR in WFC6. clarify. - erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. - 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. admit. (*ez*) } - erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. - 2:{ admit. (* same ez *) } - 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. - admit. (*ez*) - * ss. erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. - 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. admit. (*ez*) } - erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. - 2:{ admit. (* same ez *) } - 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. - - (** Case 2: Cross Return *) - - 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. - - 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)). - { destruct MS2 as (MFUN0 & MFUN1). auto. } - - exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } - 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. - - 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). - 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. } - - 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_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_C in H. clarify. } - subst b0. assert (f0 = f). - { rewrite FINDF_C_CUR in H0. clarify. } - subst f0. 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. - admit. (*ez*) - * 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. assert (fd_cur = AST.Internal f_i_cur). - { rewrite FINDFD in FINDF_I_CUR; clarify. } - subst fd_cur. eapply sem_cast_proj_rettype. ss. 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 FINDF_I_CUR. 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. - assert (fd_cur = AST.Internal f_i_cur). - { rewrite FINDFD in FINDF_I_CUR; clarify. } - subst fd_cur. ss. erewrite proj_rettype_to_type_rettype_of_type_eq. 2: eapply H0. - eapply match_senv_eventval_match. 2: eapply H0. destruct MS0 as (MS0 & _). auto. - } - 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. - - (** Case 3: Internal-External Call *) - - assert (id = id_cur). - { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } - subst id. rename id0 into id_next. - - 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_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)). - { destruct MS2 as (MFUN0 & MFUN1). auto. } - - exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } - destruct WF_CNT_CUR as (CNT_CUR_NPUB & cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). - - 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). - 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. } - - 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 (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_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_C in H. clarify. } - subst b. assert (f0 = f). - { rewrite FINDF_C_CUR in H0. clarify. } - subst f0. ss. 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. - admit. (*ez*) - * 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_C in H. clarify. } - subst b. assert (f0 = f). - { rewrite FINDF_C_CUR in H0. clarify. } - subst f0. 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: 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. - admit. (*ez*) - } - * 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. - } - } - } - - (** Case 4: Builtins *) - - assert (id = id_cur). - { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } - subst id. - - set (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr) as ttr in *. - 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)). - { destruct MS2 as (MFUN0 & MFUN1). auto. } - - exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } - destruct WF_CNT_CUR as (CNT_CUR_NPUB & cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). - - 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). - 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. } - - 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_C in H. clarify. } - subst b. assert (f0 = f). - { rewrite FINDF_C_CUR in H0. clarify. } - subst f0. ss. 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. - admit. (*ez*) - * 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_C in H. clarify. } - subst b. assert (f0 = f). - { rewrite FINDF_C_CUR in H0. clarify. } - subst f0. 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: 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. - admit. (*ez*) - } - * 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. - } - } - } - - (** Case 5: Cross Call External 1 *) - - - - - TODO - - - - - Admitted. - - Lemma ir_to_clight_aux - (ge_i: Asm.genv) (ge_c: Clight.genv) - (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_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) - (WFCG: wf_c_genv ge_c) - ist cst - ttr cnts k id - (WFC: wf_c_state ge_c [] ttr cnts id cst) - (MS: match_state ge_i ge_c k ttr cnts 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. 4,5,6,7: eauto. all: eauto. econs 1. ss. econs 1. Qed. - - End PROOF. + (* End PROOF. *) (* Genv.initmem_inject: forall [F V : Type] {CF : has_comp F} (p : AST.program F V) [m : mem], Genv.init_mem p = Some m -> Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m *) (* Genv.alloc_globals_neutral: *) (* forall [F V : Type] {CF : has_comp F} (ge : Genv.t F V) [thr : block], *) (* (forall (id : ident) (b : block), Genv.find_symbol ge id = Some b -> Plt b thr) -> *) (* forall (gl : list (ident * globdef F V)) (m m' : mem), Genv.alloc_globals ge m gl = Some m' -> Mem.inject_neutral thr m -> Ple (Mem.nextblock m') thr -> Mem.inject_neutral thr m' *) - - - - Section STEPPROP. - - (* Variant external_call_event_match_common *) - (* (ef: external_function) (ev: event) (ge: Senv.t) (cp: compartment) (m1: mem) *) - (* : val -> mem -> Prop := *) - (* | ext_match_vload *) - (* ch *) - (* (EF: ef = EF_vload ch) *) - (* id ofs evv *) - (* (EV: ev = Event_vload ch id ofs evv) *) - (* b res m2 *) - (* (SEM: volatile_load_sem ch ge cp (Vptr b ofs :: nil) m1 (ev :: nil) res m2) *) - (* : *) - (* external_call_event_match_common ef ev ge cp m1 res m2 *) - (* | ext_match_vstore *) - (* ch *) - (* (EF: ef = EF_vstore ch) *) - (* id ofs evv *) - (* (EV: ev = Event_vstore ch id ofs evv) *) - (* b argv m2 *) - (* (SEM: volatile_store_sem ch ge cp (Vptr b ofs :: argv :: nil) m1 (ev :: nil) Vundef m2) *) - (* : *) - (* external_call_event_match_common ef ev ge cp m1 Vundef m2 *) - (* | ext_match_annot *) - (* len text targs *) - (* (EF: ef = EF_annot len text targs) *) - (* evargs *) - (* (EV: ev = Event_annot text evargs) *) - (* vargs m2 *) - (* (SEM: extcall_annot_sem text targs ge cp vargs m1 (ev :: nil) Vundef m2) *) - (* : *) - (* external_call_event_match_common ef ev ge cp m1 Vundef m2 *) - (* | ext_match_external *) - (* name excp sg *) - (* (EF: ef = EF_external name excp sg) *) - (* evname evargs evres *) - (* (EV: ev = Event_syscall evname evargs evres) *) - (* vargs vres m2 *) - (* (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) *) - (* (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) *) - (* : *) - (* external_call_event_match_common ef ev ge cp m1 vres m2 *) - (* | ext_match_builtin *) - (* name sg *) - (* (EF: (ef = EF_builtin name sg) \/ (ef = EF_runtime name sg)) *) - (* evname evargs evres *) - (* (EV: ev = Event_syscall evname evargs evres) *) - (* (ISEXT: Builtins.lookup_builtin_function name sg = None) *) - (* vargs vres m2 *) - (* (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) *) - (* (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) *) - (* : *) - (* external_call_event_match_common ef ev ge cp m1 vres m2 *) - (* | ext_match_inline_asm *) - (* txt sg strs *) - (* (EF: ef = EF_inline_asm txt sg strs) *) - (* evname evargs evres *) - (* (EV: ev = Event_syscall evname evargs evres) *) - (* vargs vres m2 *) - (* (SEM: inline_assembly_sem txt sg ge cp vargs m1 (ev :: nil) vres m2) *) - (* (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) *) - (* : *) - (* external_call_event_match_common ef ev ge cp m1 vres m2 *) - (* . *) - - Variant external_call_wf_env (ev: event) (e: env): Prop := - | ext_wf_env_vload - ch id ofs evv - (EV: ev = Event_vload ch id ofs evv) - (WF: wf_env e id) - : - external_call_wf_env ev e - | ext_wf_env_vstore - ch id ofs evv - (EV: ev = Event_vstore ch id ofs evv) - (WF0: wf_env e id) - (WF1: wf_eventval_env e evv) - : - external_call_wf_env ev e - | ext_wf_env_annot - text evargs - (EV: ev = Event_annot text evargs) - (WFENV: Forall (wf_eventval_env e) evargs) - : - external_call_wf_env ev e - | ext_wf_env_syscall - evname evargs evres - (EV: ev = Event_syscall evname evargs evres) - (WFENV: Forall (wf_eventval_env e) evargs) - : - external_call_wf_env ev e. - - Definition external_call_event_match (ef: external_function) (ev: event) (ge: Senv.t) (cp: compartment) (m1: mem) (e: env) : val -> mem -> Prop := - fun res m2 => - (external_call_event_match_common ef ev ge cp m1 res m2) /\ (external_call_wf_env ev e). - - (* Variant external_call_event_match (ef: external_function) (ev: event) (ge: Senv.t) (cp: compartment) (m1: mem) (e: env) : val -> mem -> Prop := *) - (* | ext_match_vload *) - (* ch *) - (* (EF: ef = EF_vload ch) *) - (* id ofs evv *) - (* (EV: ev = Event_vload ch id ofs evv) *) - (* (WF: wf_env e id) *) - (* b res m2 *) - (* (SEM: volatile_load_sem ch ge cp (Vptr b ofs :: nil) m1 (ev :: nil) res m2) *) - (* : *) - (* external_call_event_match ef ev ge cp m1 e res m2 *) - (* | ext_match_vstore *) - (* ch *) - (* (EF: ef = EF_vstore ch) *) - (* id ofs evv *) - (* (EV: ev = Event_vstore ch id ofs evv) *) - (* (WF0: wf_env e id) *) - (* (WF1: wf_eventval_env e evv) *) - (* b argv m2 *) - (* (SEM: volatile_store_sem ch ge cp (Vptr b ofs :: argv :: nil) m1 (ev :: nil) Vundef m2) *) - (* : *) - (* external_call_event_match ef ev ge cp m1 e Vundef m2 *) - (* | ext_match_annot *) - (* len text targs *) - (* (EF: ef = EF_annot len text targs) *) - (* evargs *) - (* (EV: ev = Event_annot text evargs) *) - (* (WFENV: Forall (wf_eventval_env e) evargs) *) - (* vargs m2 *) - (* (SEM: extcall_annot_sem text targs ge cp vargs m1 (ev :: nil) Vundef m2) *) - (* : *) - (* external_call_event_match ef ev ge cp m1 e Vundef m2 *) - (* | ext_match_external *) - (* name excp sg *) - (* (EF: ef = EF_external name excp sg) *) - (* evname evargs evres *) - (* (EV: ev = Event_syscall evname evargs evres) *) - (* (WFENV: Forall (wf_eventval_env e) evargs) *) - (* vargs vres m2 *) - (* (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) *) - (* (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) *) - (* : *) - (* external_call_event_match ef ev ge cp m1 e vres m2 *) - (* | ext_match_builtin *) - (* name sg *) - (* (EF: (ef = EF_builtin name sg) \/ (ef = EF_runtime name sg)) *) - (* evname evargs evres *) - (* (EV: ev = Event_syscall evname evargs evres) *) - (* (WFENV: Forall (wf_eventval_env e) evargs) *) - (* (ISEXT: Builtins.lookup_builtin_function name sg = None) *) - (* vargs vres m2 *) - (* (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) *) - (* (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) *) - (* : *) - (* external_call_event_match ef ev ge cp m1 e vres m2 *) - (* | ext_match_inline_asm *) - (* txt sg strs *) - (* (EF: ef = EF_inline_asm txt sg strs) *) - (* evname evargs evres *) - (* (EV: ev = Event_syscall evname evargs evres) *) - (* (WFENV: Forall (wf_eventval_env e) evargs) *) - (* vargs vres m2 *) - (* (SEM: inline_assembly_sem txt sg ge cp vargs m1 (ev :: nil) vres m2) *) - (* (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) *) - (* : *) - (* external_call_event_match ef ev ge cp m1 e vres m2 *) - (* . *) - - (* Step lemmas *) - Lemma code_of_event_step_intra_call_ext - ev ik ef - p f k e le m1 ge cp res m2 - (CP: cp = comp_of f) - (GE: ge = globalenv p) - (EXT: external_call_event_match ef ev ge cp m1 e res m2) - fb - (IK: ik = info_external fb (ef_sig ef)) - fid - (INV: Genv.invert_symbol ge fb = Some fid) - (WF: wf_env e fid) - (* bt_wf *) - (* from_asm *) - (ISEXT: let tys := from_sig_fun_data (ef_sig ef) in - Genv.find_funct_ptr ge fb = Some (Ctypes.External ef (dargs tys) (dret tys) (dcc tys))) - (ALLOWED: Genv.allowed_call ge cp (Vptr fb Ptrofs.zero)) - (INTRA: Genv.type_of_call ge cp (Genv.find_comp ge (Vptr fb Ptrofs.zero)) <> Genv.CrossCompartmentCall) - : - Star (Clight.semantics1 p) - (State f (code_of_ievent ge (ev, ik)) k e le m1) - (ev :: nil) - (State f Sskip k e le m2). - Proof. - destruct EXT as [EXT ENV]. inv EXT; subst; simpl in *. - - inv ENV; inv EV. - pose proof SEM as SEM0. inv SEM. inv H5. rewrite INV. econstructor 2. - { eapply step_call. - 4:{ instantiate (2:=Vptr fb Ptrofs.zero). unfold Genv.find_funct. rewrite pred_dec_true; eauto. } - 4:{ simpl. eauto. } - auto. - { eapply eval_Elvalue. eapply eval_Evar_global; auto. eapply Genv.invert_find_symbol; eauto. simpl. econstructor 2. auto. } - { econstructor; eauto. 3: econstructor. eapply ptr_of_id_ofs_eval; eauto. - rewrite ptr_of_id_ofs_typeof. eapply sem_cast_ptr. - } - auto. - { intros F. simpl in *. contradiction. } - { econstructor 1. auto. } - } - econstructor 2. - { eapply step_external_function. simpl. eauto. } - econstructor 2. - { unfold Genv.find_comp, Genv.find_funct in INTRA. rewrite pred_dec_true in INTRA; auto. rewrite ISEXT in INTRA; simpl in INTRA. unfold comp_of at 2 in INTRA. simpl in INTRA. - eapply step_returnstate; simpl. - - intros F. contradiction. - - econstructor 1. auto. - } - simpl. econstructor 1. all: eauto. - - inv ENV; inv EV. - pose proof SEM as SEM0. inv SEM. inv H5. rewrite INV. econstructor 2. - { eapply step_call. - 4:{ instantiate (2:=Vptr fb Ptrofs.zero). unfold Genv.find_funct. rewrite pred_dec_true; eauto. } - 4:{ simpl. eauto. } - auto. - { eapply eval_Elvalue. eapply eval_Evar_global; auto. eapply Genv.invert_find_symbol; eauto. simpl. econstructor 2. auto. } - { econstructor; eauto. eapply ptr_of_id_ofs_eval; eauto. - rewrite ptr_of_id_ofs_typeof. eapply sem_cast_ptr. - econstructor; eauto. 3: econstructor. eapply eventval_to_expr_val_eval; auto. - eapply eventval_match_wf_eventval_ge; eauto. - eapply eventval_match_sem_cast. erewrite eventval_match_eventval_to_val; eauto. - } - auto. - { intros F. simpl in *. contradiction. } - { econstructor 1. auto. } - } - econstructor 2. - { eapply step_external_function. unfold call_comp. simpl. econstructor. econstructor 1; eauto. eapply val_load_result_aux; eauto. } - econstructor 2. - { unfold Genv.find_comp, Genv.find_funct in INTRA. rewrite pred_dec_true in INTRA; auto. rewrite ISEXT in INTRA; simpl in INTRA. unfold comp_of at 2 in INTRA. simpl in INTRA. - eapply step_returnstate; simpl. - - intros F. contradiction. - - econstructor 1. auto. - } - simpl. econstructor 1. all: eauto. - - inv ENV; inv EV. - pose proof SEM as SEM0. inv SEM. rewrite INV. econstructor 2. - { eapply step_call. - 4:{ instantiate (2:=Vptr fb Ptrofs.zero). unfold Genv.find_funct. rewrite pred_dec_true; eauto. } - 4:{ simpl. eauto. } - auto. - { eapply eval_Elvalue. eapply eval_Evar_global; auto. eapply Genv.invert_find_symbol; eauto. simpl. econstructor 2. auto. } - { eapply list_eventval_to_expr_val_eval_typs; eauto. } - auto. - { intros F. simpl in *. contradiction. } - { econstructor 1. auto. } - } - econstructor 2. - { eapply step_external_function. unfold call_comp. simpl. eauto. } - econstructor 2. - { unfold Genv.find_comp, Genv.find_funct in INTRA. rewrite pred_dec_true in INTRA; auto. rewrite ISEXT in INTRA; simpl in INTRA. unfold comp_of at 2 in INTRA. simpl in INTRA. - eapply step_returnstate; simpl. - - intros F. contradiction. - - econstructor 1. auto. - } - simpl. econstructor 1. all: eauto. - - inv ENV; inv EV. rewrite INV. econstructor 2. - { eapply step_call. - 4:{ instantiate (2:=Vptr fb Ptrofs.zero). unfold Genv.find_funct. rewrite pred_dec_true; eauto. } - 4:{ simpl. eauto. } - auto. - { eapply eval_Elvalue. eapply eval_Evar_global; auto. eapply Genv.invert_find_symbol; eauto. simpl. econstructor 2. auto. } - { eapply list_eventval_to_expr_val_eval_typs; eauto. } - auto. - { intros F. simpl in *. contradiction. } - { econstructor 1. auto. } - } - econstructor 2. - { eapply step_external_function. unfold call_comp. simpl. eauto. } - econstructor 2. - { unfold Genv.find_comp, Genv.find_funct in INTRA. rewrite pred_dec_true in INTRA; auto. rewrite ISEXT in INTRA; simpl in INTRA. unfold comp_of at 2 in INTRA. simpl in INTRA. - eapply step_returnstate; simpl. - - intros F. contradiction. - - econstructor 1. auto. - } - simpl. econstructor 1. all: eauto. - - inv ENV; inv EV. rewrite INV. econstructor 2. - { eapply step_call. - 4:{ instantiate (2:=Vptr fb Ptrofs.zero). unfold Genv.find_funct. rewrite pred_dec_true; eauto. } - 4:{ simpl. eauto. } - auto. - { eapply eval_Elvalue. eapply eval_Evar_global; auto. eapply Genv.invert_find_symbol; eauto. simpl. econstructor 2. auto. } - { eapply list_eventval_to_expr_val_eval_typs; eauto. destruct EF; subst; simpl; eauto. } - auto. - { intros F. simpl in *. contradiction. } - { econstructor 1. auto. } - } - econstructor 2. - { eapply step_external_function. unfold call_comp. simpl. destruct EF; subst; simpl; red; rewrite ISEXT0; eauto. } - econstructor 2. - { unfold Genv.find_comp, Genv.find_funct in INTRA. rewrite pred_dec_true in INTRA; auto. rewrite ISEXT in INTRA; simpl in INTRA. unfold comp_of at 2 in INTRA. simpl in INTRA. - eapply step_returnstate; simpl. - - intros F. contradiction. - - econstructor 1. auto. - } - simpl. econstructor 1. all: eauto. - - inv ENV; inv EV. rewrite INV. econstructor 2. - { eapply step_call. - 4:{ instantiate (2:=Vptr fb Ptrofs.zero). unfold Genv.find_funct. rewrite pred_dec_true; eauto. } - 4:{ simpl. eauto. } - auto. - { eapply eval_Elvalue. eapply eval_Evar_global; auto. eapply Genv.invert_find_symbol; eauto. simpl. econstructor 2. auto. } - { eapply list_eventval_to_expr_val_eval_typs; eauto. } - auto. - { intros F. simpl in *. contradiction. } - { econstructor 1. auto. } - } - econstructor 2. - { eapply step_external_function. unfold call_comp. simpl. eauto. } - econstructor 2. - { unfold Genv.find_comp, Genv.find_funct in INTRA. rewrite pred_dec_true in INTRA; auto. rewrite ISEXT in INTRA; simpl in INTRA. unfold comp_of at 2 in INTRA. simpl in INTRA. - eapply step_returnstate; simpl. - - intros F. contradiction. - - econstructor 1. auto. - } - simpl. econstructor 1. all: eauto. - Qed. - - Lemma code_of_event_step_builtin - ev ik ef - p f k e le m1 ge cp res m2 - (CP: cp = comp_of f) - (GE: ge = globalenv p) - (EXT: external_call_event_match ef ev ge cp m1 e res m2) - (IK: ik = info_builtin ef) - (* bt_wf *) - (* from_asm *) - : - Star (Clight.semantics1 p) - (State f (code_of_ievent ge (ev, ik)) k e le m1) - (ev :: nil) - (State f Sskip k e le m2). - Proof. - destruct EXT as [EXT ENV]. inv EXT; subst; simpl in *. - - inv ENV; inv EV. pose proof SEM as SEM0. inv SEM. inv H5. econstructor 2. - { eapply step_builtin; eauto. - econstructor; eauto. 3: econstructor. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. eapply sem_cast_ptr. - } - simpl. econstructor 1. all: eauto. - - inv ENV; inv EV. pose proof SEM as SEM0. inv SEM. inv H5. econstructor 2. - { apply val_load_result_aux in H10. - eapply step_builtin. - - econstructor; eauto. eapply ptr_of_id_ofs_eval; eauto. rewrite ptr_of_id_ofs_typeof. eapply sem_cast_ptr. - econstructor; eauto. 3: econstructor. eapply eventval_to_expr_val_eval; auto. eapply eventval_match_wf_eventval_ge; eauto. - eapply eventval_match_sem_cast. erewrite eventval_match_eventval_to_val; eauto. - - simpl. econstructor. econstructor 1; eauto. - } - simpl. econstructor 1. all: eauto. - - inv ENV; inv EV. pose proof SEM as SEM0. inv SEM. econstructor 2. - { eapply step_builtin; eauto. eapply list_eventval_to_expr_val_eval_typs; eauto. } - simpl. econstructor 1. all: eauto. - - inv ENV; inv EV. econstructor 2. - { eapply step_builtin; eauto. eapply list_eventval_to_expr_val_eval_typs; eauto. } - simpl. econstructor 1. all: eauto. - - inv ENV; inv EV. econstructor 2. - { destruct EF; subst; simpl. - - eapply step_builtin. eapply list_eventval_to_expr_val_eval_typs; eauto. - simpl. red. rewrite ISEXT. eauto. - - eapply step_builtin. eapply list_eventval_to_expr_val_eval_typs; eauto. - simpl. red. rewrite ISEXT. eauto. - } - simpl. econstructor 1. all: eauto. - - inv ENV; inv EV. econstructor 2. - { eapply step_builtin; eauto. eapply list_eventval_to_expr_val_eval_typs; eauto. } - simpl. econstructor 1. all: eauto. - Qed. - - Lemma code_of_event_step_cross_call_ext - (* ev ef *) - tr ef - p k m ge cp vres m' - targs tres cconv vargs - (CP: cp = call_comp k) - (GE: ge = globalenv p) - (* (EXT: external_call ef ge cp vargs m (ev :: nil) vres m') *) - (EXT: external_call ef ge cp vargs m tr vres m') - (* bt_wf *) - (* from_asm *) - : - Star (Clight.semantics1 p) - (Callstate (External ef targs tres cconv) vargs k m) - (tr) - (* (ev :: nil) *) - (Returnstate vres k m' (rettype_of_type tres) (comp_of ef)). - Proof. - subst; simpl in *. econstructor 2. eapply step_external_function. eauto. - econstructor 1. traceEq. - Qed. - - Lemma code_of_event_step_cross_call_start - ev ik - p f k e le m ge cp - (CP: cp = comp_of f) - (GE: ge = globalenv p) - cp' fid evargs - (EV: ev = Event_call cp cp' fid evargs) - ce sg - (IK: ik = info_call ce sg) - (WF0: wf_env e fid) - (WF1: Forall (wf_eventval_env e) evargs) - tdata - (TD: tdata = from_sig_fun_data sg) - args - (ARGS: args = list_eventval_to_list_val ge evargs) - b - (FINDB: Genv.find_symbol ge fid = Some b) - fd - (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) - (TYPEF: type_of_fundef fd = Tfunction tdata.(dargs) tdata.(dret) tdata.(dcc)) - (CP': cp' = comp_of fd) - (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) - (NPTR: Forall not_ptr args) - (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) - (ESM: eventval_list_match ge evargs (sig_args sg) args) - : - Star (Clight.semantics1 p) - (State f (code_of_ievent ge (ev, ik)) k e le m) - (ev :: nil) - (Callstate fd args (Kcall None f e le k) m). - Proof. - subst; simpl. econstructor 2. - { eapply step_call. 4: eauto. all: simpl; eauto. - { econstructor. econstructor 2; eauto. simpl. econstructor 2; auto. } - { eapply list_eventval_to_expr_val_eval_typs; auto. } - { red. auto. } - { econstructor 2; eauto. - - unfold Genv.find_comp. setoid_rewrite FINDF. auto. - - eapply Genv.find_invert_symbol; eauto. - - eapply eventval_list_match_transl; eauto. - } - } - { econstructor 1. } - { simpl. unfold Genv.find_comp. - unfold Genv.find_funct in *. simpl in *. rewrite FINDF. auto. - } - Qed. - - Lemma code_of_event_step_cross_call_int - p f vargs k m1 m2 e le - (ENT: function_entry1 (globalenv p) f vargs m1 e le m2) - : - Star (Clight.semantics1 p) - (Callstate (Internal f) vargs k m1) - (nil) - (State f (fn_body f) k e le m2). - Proof. - subst; simpl in *. econstructor 2. eapply step_internal_function. eauto. - econstructor 1. auto. - Qed. - - Lemma code_of_event_step_cross_returnstate - ev ik sg evres - p ge res optid f e le k m ty cp - (GE: ge = globalenv p) - (EV: ev = Event_return (comp_of f) cp evres) - (IK: ik = info_return sg) - (CROSS: Genv.type_of_call ge (comp_of f) cp = Genv.CrossCompartmentCall) - (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) res) - (NPTR: not_ptr res) - (RETTY: ty = sig_res sg) - : - Star (Clight.semantics1 p) - (Returnstate res (Kcall optid f e le k) m ty cp) - (ev :: nil) - (State f Sskip k e (set_opttemp optid res le) m). - Proof. - subst; simpl. econstructor 2. - { eapply step_returnstate; eauto. econstructor 2; eauto. } - econstructor 1. auto. - Qed. - - Lemma code_of_event_step_cross_return_code - ev ik - p f k e le m ge cp - (CP: cp = comp_of f) - (GE: ge = globalenv p) - cp_c evres - (EV: ev = Event_return cp_c cp evres) - (WF: wf_eventval_env e evres) - sg - (IK: ik = info_return sg) - (CROSS: Genv.type_of_call ge cp_c cp = Genv.CrossCompartmentCall) - optid f_c e_c le_c k_c - (CONT: call_cont k = Kcall optid f_c e_c le_c k_c) - (CPC: cp_c = comp_of f_c) - res - (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) res) - (NPTR: not_ptr res) - (TY: fn_return f = rettype_to_type (sig_res sg)) - m' - (FREE: Mem.free_list m (blocks_of_env ge e) cp = Some m') - : - Star (Clight.semantics1 p) - (State f (code_of_ievent ge (ev, ik)) k e le m) - (ev :: nil) - (State f_c Sskip k_c e_c (set_opttemp optid res le_c) m'). - Proof. - subst; simpl. exploit eventval_match_eventval_to_val. eapply EVM. intros RES. - econstructor 2. - { eapply step_return_1; eauto. - { eapply eventval_to_expr_val_eval; auto. eapply eventval_match_wf_eventval_ge; eauto. } - { rewrite TY. eapply sem_cast_proj_rettype. eauto. } - } - econstructor 2. - { rewrite CONT. eapply step_returnstate. - { subst res. auto. } - { econstructor 2; auto. rewrite TY. erewrite proj_rettype_to_type_rettype_of_type_eq. - 2: eauto. subst res; eauto. - } - } - { subst res. econstructor 1. } - all: eauto. - Qed. - - End STEPPROP. - - - (* Section WELLFORMED. *) - - (* Definition empty_te: temp_env := PTree.empty val. *) - - (* (* Variant sf_cont_type : Type := | sf_cont: block -> signature -> sf_cont_type. *) *) - (* Variant sf_cont_type : Type := | sf_cont: block -> sf_cont_type. *) - (* Definition sf_conts := list sf_cont_type. *) - - (* (* wf_sem: from asm, wf_st: proof invariant for Clight states *) *) - (* Inductive from_info_asm_wf (ge: Asm.genv) : block -> mem -> sf_conts -> itrace -> Prop := *) - (* | from_info_asm_wf_intra_call_external *) - (* cur m1 sf ev ik tl *) - (* cp *) - (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) - (* ef res m2 *) - (* (EXTEV: external_call_event_match_common ef ev ge cp m1 res m2) *) - (* fb *) - (* (IK: ik = info_external fb (ef_sig ef)) *) - (* fid *) - (* (INV: Genv.invert_symbol ge fb = Some fid) *) - (* (ISEXT: Genv.find_funct_ptr ge fb = Some (AST.External ef)) *) - (* (ALLOWED: Genv.allowed_call ge cp (Vptr fb Ptrofs.zero)) *) - (* (INTRA: Genv.type_of_call ge cp (Genv.find_comp ge (Vptr fb Ptrofs.zero)) <> Genv.CrossCompartmentCall) *) - (* (NEXT: from_info_asm_wf ge cur m2 sf tl) *) - (* : *) - (* from_info_asm_wf ge cur m1 sf ((ev, ik) :: tl) *) - (* | from_info_asm_wf_builtin *) - (* cur m1 sf ev ik tl *) - (* cp *) - (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) - (* ef res m2 *) - (* (EXT: external_call_event_match_common ef ev ge cp m1 res m2) *) - (* (IK: ik = info_builtin ef) *) - (* (NEXT: from_info_asm_wf ge cur m2 sf tl) *) - (* : *) - (* from_info_asm_wf ge cur m1 sf ((ev, ik) :: tl) *) - (* | from_info_asm_wf_cross_call_internal *) - (* cur m1 sf ev ik tl *) - (* cp *) - (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) - (* cp' fid evargs *) - (* (EV: ev = Event_call cp cp' fid evargs) *) - (* sg *) - (* (IK: ik = info_call not_cross_ext sg) *) - (* b *) - (* (FINDB: Genv.find_symbol ge fid = Some b) *) - (* fd *) - (* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) *) - (* (CP': cp' = comp_of fd) *) - (* (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) *) - (* args *) - (* (NPTR: Forall not_ptr args) *) - (* (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) *) - (* (ESM: eventval_list_match ge evargs (sig_args sg) args) *) - (* callee_f *) - (* (INTERNAL: fd = AST.Internal callee_f) *) - (* (* TODO: separate this; *) - (* might be better to upgrade Asm semantics to actually refer to its fn_sig. *) - (* Note that it's not possible to recover Clight fun type data from trace since *) - (* there can be conflicts, since Asm semantics actually allows non-fixed sigs. *) - (* *) *) - (* (SIG: sg = Asm.fn_sig callee_f) *) - (* (* internal call: memory changes in Clight-side, so need inj-relation *) *) - (* (NEXT: from_info_asm_wf ge b m1 ((sf_cont cur) :: sf) tl) *) - (* : *) - (* from_info_asm_wf ge cur m1 sf ((ev, ik) :: tl) *) - (* | from_info_asm_wf_cross_return_internal *) - (* cur m1 ev ik tl *) - (* cp *) - (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) - (* cp_c evres *) - (* (EV: ev = Event_return cp_c cp evres) *) - (* sg *) - (* (IK: ik = info_return sg) *) - (* cur_f *) - (* (INTERNAL: Genv.find_funct_ptr ge cur = Some (AST.Internal cur_f)) *) - (* (* TODO: separate this *) *) - (* (SIG: sg = Asm.fn_sig cur_f) *) - (* (CROSS: Genv.type_of_call ge cp_c cp = Genv.CrossCompartmentCall) *) - (* res *) - (* (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) res) *) - (* (NPTR: not_ptr res) *) - (* b_c sf_tl *) - (* (CPC: cp_c = Genv.find_comp ge (Vptr b_c Ptrofs.zero)) *) - (* (* internal return: memory changes in Clight-side, so need inj-relation *) *) - (* (NEXT: from_info_asm_wf ge b_c m1 sf_tl tl) *) - (* : *) - (* from_info_asm_wf ge cur m1 ((sf_cont b_c) :: sf_tl) ((ev, ik) :: tl) *) - (* | from_info_asm_wf_cross_call_external1 *) - (* (* early cut at call event *) *) - (* cur m1 sf ev ik *) - (* cp *) - (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) - (* cp' fid evargs *) - (* (EV: ev = Event_call cp cp' fid evargs) *) - (* sg *) - (* (IK: ik = info_call is_cross_ext sg) *) - (* b *) - (* (FINDB: Genv.find_symbol ge fid = Some b) *) - (* fd *) - (* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) *) - (* (CP': cp' = comp_of fd) *) - (* (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) *) - (* args *) - (* (NPTR: Forall not_ptr args) *) - (* (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) *) - (* (ESM: eventval_list_match ge evargs (sig_args sg) args) *) - (* ef *) - (* (EXTERNAL: fd = AST.External ef) *) - (* (* TODO: separate this *) *) - (* (SIG: sg = ef_sig ef) *) - (* : *) - (* from_info_asm_wf ge cur m1 sf ((ev, ik) :: nil) *) - (* | from_info_asm_wf_cross_call_external2 *) - (* (* early cut at call-ext_call event *) *) - (* cur m1 sf ev1 ik1 *) - (* cp *) - (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) - (* cp' fid evargs *) - (* (EV: ev1 = Event_call cp cp' fid evargs) *) - (* sg *) - (* (IK: ik1 = info_call is_cross_ext sg) *) - (* b *) - (* (FINDB: Genv.find_symbol ge fid = Some b) *) - (* fd *) - (* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) *) - (* (CP': cp' = comp_of fd) *) - (* (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) *) - (* args *) - (* (NPTR: Forall not_ptr args) *) - (* (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) *) - (* (ESM: eventval_list_match ge evargs (sig_args sg) args) *) - (* ef *) - (* (EXTERNAL: fd = AST.External ef) *) - (* (* TODO: separate this *) *) - (* (SIG: sg = ef_sig ef) *) - (* (* external call part *) *) - (* tr vres m2 *) - (* (EXTCALL: external_call ef ge cp args m1 tr vres m2) *) - (* itr *) - (* (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) *) - (* : *) - (* from_info_asm_wf ge cur m1 sf ((ev1, ik1) :: itr) *) - (* | from_info_asm_wf_cross_call_external3 *) - (* (* full call-ext_call-return event *) *) - (* cur m1 sf ev1 ik1 *) - (* cp *) - (* (CURCP: cp = Genv.find_comp ge (Vptr cur Ptrofs.zero)) *) - (* cp' fid evargs *) - (* (EV: ev1 = Event_call cp cp' fid evargs) *) - (* sg *) - (* (IK: ik1 = info_call is_cross_ext sg) *) - (* b *) - (* (FINDB: Genv.find_symbol ge fid = Some b) *) - (* fd *) - (* (FINDF: Genv.find_funct ge (Vptr b Ptrofs.zero) = Some fd) *) - (* (CP': cp' = comp_of fd) *) - (* (CROSS: Genv.type_of_call ge cp cp' = Genv.CrossCompartmentCall) *) - (* args *) - (* (NPTR: Forall not_ptr args) *) - (* (ALLOW: Genv.allowed_cross_call ge cp (Vptr b Ptrofs.zero)) *) - (* (ESM: eventval_list_match ge evargs (sig_args sg) args) *) - (* ef *) - (* (EXTERNAL: fd = AST.External ef) *) - (* (* TODO: separate this *) *) - (* (SIG: sg = ef_sig ef) *) - (* (* external call part *) *) - (* tr vres m2 *) - (* (EXTCALL: external_call ef ge cp args m1 tr vres m2) *) - (* itr *) - (* (INFO: itr = map (fun e => (e, info_external b (ef_sig ef))) tr) *) - (* (* return part *) *) - (* ev3 ik3 tl *) - (* evres *) - (* (EV: ev3 = Event_return cp cp' evres) *) - (* sg *) - (* (IK: ik3 = info_return sg) *) - (* (EVM: eventval_match ge evres (proj_rettype (sig_res sg)) vres) *) - (* (NPTR: not_ptr vres) *) - (* (NEXT: from_info_asm_wf ge cur m2 sf tl) *) - (* : *) - (* from_info_asm_wf ge cur m1 sf ((ev1, ik1) :: (itr ++ ((ev3, ik3) :: tl))) *) - (* . *) - - (* (* TODO *) *) - (* (* we need a more precise invariant for the proof; counters, mem_inj, env, cont, state *) *) - - (* End WELLFORMED. *) - - - Section PROJ. - (** Projection of the trace according to compartments **) - - Definition comp_of_event (e: event): option (compartment * compartment) := - match e with - | Event_call cp cp' id vs => Some (cp, cp') - | Event_return cp' cp v => Some (cp, cp') - | _ => None - end. - - (* Instance has_comp_event: has_comp event := *) - - Definition comp_proj_trace (cp: compartment) (t: trace): compartment * trace := - fold_right - (fun ev '(cp_now, sub) => match comp_of_event ev with - | Some (cp_curr, cp_next) => (cp_next, if (Pos.eqb cp_curr cp) then (ev :: sub) else sub) - | None => (cp_now, if (Pos.eqb cp_now cp) then (ev :: sub) else sub) - end) - (default_compartment, nil) t. - - Definition comp_subtrace (cp: compartment) (t: trace) := - snd (comp_proj_trace cp t). - - Definition code_of_subtrace cp t := - code_of_trace cp (comp_subtrace cp t). - - Definition codes_of_subtraces (cps: list compartment) t : PTree.t statement := - PTree_Properties.of_list (map (fun cp => (cp, code_of_subtrace cp t)) cps). - - Definition get_cps_from_policy (p: Policy.t): list compartment := - map fst (PTree.elements p.(Policy.policy_export)). - - End PROJ. - - - (* TODO *) - (* Axiom backtranslation: Asm.program -> split -> trace -> Clight.program * Clight.program. *) - (* Axiom backtranslation_correct: *) - (* forall pol s t p C, *) - (* backtranslation pol s t = (p, C) -> *) - (* clight_compatible s p C /\ *) - (* exists W, link p C = Some W /\ *) - (* clight_program_has_initial_trace W t. *) - - (* Definition clight_has_side (s: split) (lr: side) (p: Clight.program) := *) - (* List.Forall (fun '(id, gd) => *) - (* match gd with *) - (* | Gfun (Ctypes.Internal f) => s (comp_of f) = lr *) - (* | _ => True *) - (* end) *) - (* (Ctypes.prog_defs p). *) - - (* Definition clight_compatible (s: split) (p p': Clight.program) := *) - (* clight_has_side s Left p /\ clight_has_side s Right p'. *) - - (* Definition clight_program_has_initial_trace (p: Clight.program) (t: trace): Prop := *) - (* forall beh, program_behaves (Clight.semantics1 p) beh -> behavior_prefix t beh. *) - - (* 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. *) - - (* Clight.program = Ctypes.program Clight.function *) - - (* old CCS version *) - Lemma comp_subtrace_app (C: Component.id) (t1 t2: trace) : - comp_subtrace C (t1 ++ t2) = comp_subtrace C t1 ++ comp_subtrace C t2. - Proof. apply: filter_cat. Qed. - - Definition procedure_of_trace C P t := - expr_of_trace C P (comp_subtrace C t). - - Definition procedures_of_trace (t: trace) : NMap (NMap expr) := - mapim (fun C Ciface => - let procs := - if C == Component.main then - Procedure.main |: Component.export Ciface - else Component.export Ciface in - mkfmapf (fun P => procedure_of_trace C P t) procs) - intf. - - Definition valid_procedure C P := - C = Component.main /\ P = Procedure.main - \/ exported_procedure intf C P. - - Lemma find_procedures_of_trace_exp (t: trace) C P : - exported_procedure intf C P -> - find_procedure (procedures_of_trace t) C P - = Some (procedure_of_trace C P t). - Proof. - intros [CI [C_CI CI_P]]. - unfold find_procedure, procedures_of_trace. - rewrite mapimE C_CI /= mkfmapfE. - case: eqP=> _; last by rewrite CI_P. - by rewrite in_fsetU1 CI_P orbT. - Qed. - - Lemma find_procedures_of_trace_main (t: trace) : - find_procedure (procedures_of_trace t) Component.main Procedure.main - = Some (procedure_of_trace Component.main Procedure.main t). - Proof. - rewrite /find_procedure /procedures_of_trace. - rewrite mapimE eqxx. - case: (intf Component.main) (has_main)=> [Cint|] //= _. - by rewrite mkfmapfE in_fsetU1 eqxx. - Qed. - - Lemma find_procedures_of_trace (t: trace) C P : - valid_procedure C P -> - find_procedure (procedures_of_trace t) C P - = Some (procedure_of_trace C P t). - Proof. - by move=> [[-> ->]|?]; - [apply: find_procedures_of_trace_main|apply: find_procedures_of_trace_exp]. - Qed. - - Definition program_of_trace (t: trace) : program := - {| prog_interface := intf; - prog_procedures := procedures_of_trace t; - prog_buffers := mapm (fun _ => inr [Int 0]) intf |}. - - (* old CCS version *) - - - Section WithTrace. - - 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 statement_of_trace: statement := - switch (map (statement_of_event cp) t) Sskip. - - - - - End WithTrace. - -End Backtranslation. - - (* Axiom backtranslation: Policy.t -> split -> trace -> Clight.program * Clight.program. *) - (* Axiom backtranslation_correct: *) - (* forall pol s t p C, *) - (* backtranslation pol s t = (p, C) -> *) - (* clight_compatible s p C /\ *) - (* exists W, link p C = Some W /\ *) - (* clight_program_has_initial_trace W t. *) - - (* Axiom backtranslation_compiles: *) - (* forall pol s t p C, *) - (* backtranslation pol s t = (p, C) -> *) - (* exists p_compiled C_compiled, *) - (* transf_clight_program p = OK p_compiled /\ *) - (* transf_clight_program C = OK C_compiled. *) - - (* 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. *) diff --git a/security/BacktranslationAux.v b/security/BacktranslationAux.v new file mode 100644 index 0000000000..07ac072357 --- /dev/null +++ b/security/BacktranslationAux.v @@ -0,0 +1,2015 @@ +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. + Admitted. + +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) + : + exists vargs2 vretv2, + (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))) 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. 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. + } + { 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. 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. eapply match_symbs_eventval_match; eauto. + - esplits. + + erewrite eventval_list_match_vals_to_eventvals. 2: eapply H. + eapply list_eventval_to_expr_val_eval; auto. eapply eventval_list_match_transl. + eapply match_senv_eventval_list_match; eauto. + + econs. eapply eventval_list_match_transl_val. 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. eapply eventval_match_sem_cast. + erewrite eventval_match_eventval_to_val. + eapply match_senv_eventval_match. eauto. eapply H. eapply match_senv_eventval_match. eauto. eapply H. + + econs. erewrite eventval_match_eventval_to_val. + eapply match_senv_eventval_match. eauto. eapply H. eapply match_senv_eventval_match. eauto. eapply H. + 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..d04193ae95 --- /dev/null +++ b/security/BacktranslationProof.v @@ -0,0 +1,1586 @@ +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: 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 (f: function), + (Genv.find_symbol ge id = Some b) -> (Genv.find_funct_ptr ge b = Some (Internal f)) -> + (exists cnt, (cnts ! id = Some cnt) /\ (wf_counter ge m (comp_of f) (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: 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 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)) + (* (wf_env ge e /\ wf_env_unique_blocks e /\ wf_env_mem ge (comp_of f) e 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). + (* /\ (public_rev_perm m_i m_c). *) + + 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_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_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_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 : 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) (f : function), + Genv.find_symbol ge_c id = Some b -> + Genv.find_funct_ptr ge_c b = Some (Internal f) -> + exists cnt : ident, + cnts ! id = Some cnt /\ + wf_counter ge_c m_c (comp_of f) (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 = [])) + : + exists cnt_cur cnt_cur_b, + (cnts ! id_cur = Some cnt_cur /\ Senv.find_symbol ge_c cnt_cur = Some cnt_cur_b) /\ + 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) + (unbundle (id_cur, Bundle_call tr id0 evargs (ef_sig ef) d)) + (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. + + 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_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)). + { destruct MS2 as (MFUN0 & MFUN1). auto. } + + exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. + } + + 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). + 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. } + + 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. + + + + (* WIP *) + 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_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_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. + (* REMOVE *) + Set Nested Proofs Allowed. + + 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 *) + - 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. + 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)). + { destruct MS2 as (MFUN0 & MFUN1). auto. } + + exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. } + + 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). + 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. } + + 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 (ENV_NINJ: not_inj_blks (meminj_public 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. *) + (* unfold meminj_public. des_ifs. exfalso. simpl in Heq. *) + (* move MS1 after Heq0. destruct MS1 as (MM1 & MM2 & MM3). *) + (* erewrite match_symbs_meminj_public in MEMINJ_CNT. *) + (* 2:{ destruct MS0 as (MS0 & _). apply MS0. } *) + (* hexploit Mem.valid_block_inject_2. 2: eapply MEMINJ_CNT. *) + (* { unfold meminj_public. setoid_rewrite Heq. rewrite Heq0. eauto. } *) + (* eapply alloc_variables_one_fresh_block. eapply ENV_ALLOC. *) + (* { rewrite app_nil_r. eapply MP1. eauto. } *) + (* ss. eapply H0. *) + (* } *) + + assert (WFC_NEXT: wf_c_state 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. + admit. (*ez*) + } + destruct (Pos.eq_dec id id_cur). + * subst id. clarify. ss. rewrite FIND_CNT_CUR in WFC6. 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. + admit. (*ez*) + * 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. + + (** Case 2: Cross Return *) + - 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. + + 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)). + { destruct MS2 as (MFUN0 & MFUN1). auto. } + + exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. + + 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). + 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. } + + 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_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_C in H. clarify. } + subst b0. assert (f0 = f). + { rewrite FINDF_C_CUR in H0. clarify. } + subst f0. 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. + admit. (*ez*) + * 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. assert (fd_cur = AST.Internal f_i_cur). + { rewrite FINDFD in FINDF_I_CUR; clarify. } + subst fd_cur. eapply sem_cast_proj_rettype. ss. 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 FINDF_I_CUR. 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. + assert (fd_cur = AST.Internal f_i_cur). + { rewrite FINDFD in FINDF_I_CUR; clarify. } + subst fd_cur. ss. erewrite proj_rettype_to_type_rettype_of_type_eq. 2: eapply H0. + eapply match_senv_eventval_match. 2: eapply H0. destruct MS0 as (MS0 & _). auto. + } + 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. + + (** Case 3: Internal-External Call *) + - assert (id = id_cur). + { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } + subst id. rename id0 into id_next. + + 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_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)). + { destruct MS2 as (MFUN0 & MFUN1). auto. } + + exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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). + + 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). + 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. } + + 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 (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_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_C in H. clarify. } + subst b. assert (f0 = f). + { rewrite FINDF_C_CUR in H0. clarify. } + subst f0. ss. 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. + admit. (*ez*) + * 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_C in H. clarify. } + subst b. assert (f0 = f). + { rewrite FINDF_C_CUR in H0. clarify. } + subst f0. 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: 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. + admit. (*ez*) + } + * 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. + } + } + } + + (** Case 4: Builtins *) + - assert (id = id_cur). + { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } + subst id. + + set (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr) as ttr in *. + 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)). + { destruct MS2 as (MFUN0 & MFUN1). auto. } + + exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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). + + 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). + 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. } + + 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_C in H. clarify. } + subst b. assert (f0 = f). + { rewrite FINDF_C_CUR in H0. clarify. } + subst f0. ss. 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. + admit. (*ez*) + * 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_C in H. clarify. } + subst b. assert (f0 = f). + { rewrite FINDF_C_CUR in H0. clarify. } + subst f0. 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: 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. + admit. (*ez*) + } + * 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. + } + } + } + + (** Case 5: Cross Call External 1 *) + - hexploit ir_to_clight_step_cce_1; eauto. + { unfold mem_delta_apply_wf. ss. } + intros (cnt_cur & cnt_cur_b & (CNT_CUR & FIND_CNT) & 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 *) + - + + + TODO + + + + + Admitted. + + 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_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) + (* (WFCG: wf_c_genv ge_c) *) + ist cst + ttr cnts pars k id + (BOUND: Z.of_nat (Datatypes.length ttr) < Int64.modulus) + (WFC: wf_c_state 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. +(* Genv.initmem_inject: forall [F V : Type] {CF : has_comp F} (p : AST.program F V) [m : mem], Genv.init_mem p = Some m -> Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m *) +(* Genv.alloc_globals_neutral: *) +(* forall [F V : Type] {CF : has_comp F} (ge : Genv.t F V) [thr : block], *) +(* (forall (id : ident) (b : block), Genv.find_symbol ge id = Some b -> Plt b thr) -> *) +(* forall (gl : list (ident * globdef F V)) (m m' : mem), Genv.alloc_globals ge m gl = Some m' -> Mem.inject_neutral thr m -> Ple (Mem.nextblock m') thr -> Mem.inject_neutral thr m' *) From c4ec336585e38854d787cc02a5e2d45ac6280e5a Mon Sep 17 00:00:00 2001 From: ldj Date: Sat, 23 Sep 2023 18:12:39 +0900 Subject: [PATCH 159/174] WIP --- security/BacktranslationAux.v | 24 ++-- security/BacktranslationProof.v | 198 +++++++++++++++++++++++++++++--- 2 files changed, 196 insertions(+), 26 deletions(-) diff --git a/security/BacktranslationAux.v b/security/BacktranslationAux.v index 07ac072357..993ec106af 100644 --- a/security/BacktranslationAux.v +++ b/security/BacktranslationAux.v @@ -1570,10 +1570,9 @@ Section PROOF. 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_typ_to_typelist (sig_args (ef_sig ef))) vargs2) /\ - (external_call ef ge2 vargs2 m_c tr vretv2 m_c). + (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). @@ -1601,7 +1600,7 @@ Section PROOF. * 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. + { rewrite EK1 in H2. destruct v; ss. - destruct chunk; ss; inv H2; ss. - destruct chunk; ss. all: simpl_expr. inv H2. @@ -1613,21 +1612,24 @@ Section PROOF. + unfold Cop.sem_cast. ss. rewrite Heq. auto. + unfold Cop.sem_cast. ss. rewrite Heq. auto. } - + econs. econs; auto. rewrite MS3; auto. rewrite EK1. eapply match_symbs_eventval_match; eauto. + + 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 eventval_list_match_transl_val. 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. eapply eventval_match_sem_cast. + * erewrite eventval_match_val_to_eventval. 2: eapply H. erewrite eventval_match_eventval_to_val. - eapply match_senv_eventval_match. eauto. eapply H. eapply match_senv_eventval_match. eauto. eapply H. - + econs. erewrite eventval_match_eventval_to_val. - eapply match_senv_eventval_match. eauto. eapply H. eapply match_senv_eventval_match. eauto. eapply H. + 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 diff --git a/security/BacktranslationProof.v b/security/BacktranslationProof.v index d04193ae95..8062900a84 100644 --- a/security/BacktranslationProof.v +++ b/security/BacktranslationProof.v @@ -223,19 +223,19 @@ Section PROOF. 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 : trace) id0 evargs ef id_cur d + 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)) < + (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 + (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)) + (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), @@ -250,7 +250,7 @@ Section PROOF. (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) + (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) @@ -267,16 +267,17 @@ Section PROOF. 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) /\ + (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) - (unbundle (id_cur, Bundle_call tr id0 evargs (ef_sig ef) d)) + (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')) + (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) /\ @@ -294,7 +295,7 @@ Section PROOF. { 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 *. + set (pretr ++ (id_cur, Bundle_call tr' id_next evargs (ef_sig ef) d) :: btr) as ttr in *. 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)). @@ -304,7 +305,7 @@ Section PROOF. 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)). + 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. @@ -407,6 +408,113 @@ Section PROOF. 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) (f : function), + Genv.find_symbol ge_c id = Some b -> + Genv.find_funct_ptr ge_c b = Some (Internal f) -> + exists cnt : ident, + cnts ! id = Some cnt /\ + wf_counter ge_c m_c (comp_of f) (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. (* WIP *) @@ -1007,7 +1115,7 @@ Section PROOF. (* 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 (vargs2 & vretv2 & EVALS & EXT2). + 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. @@ -1509,9 +1617,9 @@ Section PROOF. (** Case 5: Cross Call External 1 *) - hexploit ir_to_clight_step_cce_1; eauto. { unfold mem_delta_apply_wf. ss. } - intros (cnt_cur & cnt_cur_b & (CNT_CUR & FIND_CNT) & m_c' & STAR & MEM). + { 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. } @@ -1519,10 +1627,70 @@ Section PROOF. { 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 (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. + } + + desH ECCASES; cycle 1. + { 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. assert (id = id_cur). + { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } + subst id. exists id_cur. split. + + - splits; auto. + { + + + TODO + + + + + 3:{ ii. rewrite CNT_CUR in H. inv H. ss. } + + - TODO From 06987c6a930d264f3a9a77cb8c517ef12c958150 Mon Sep 17 00:00:00 2001 From: ldj Date: Sat, 23 Sep 2023 18:18:23 +0900 Subject: [PATCH 160/174] WIP --- security/BacktranslationProof.v | 38 ++++++++++++++++++++++++++++----- 1 file changed, 33 insertions(+), 5 deletions(-) diff --git a/security/BacktranslationProof.v b/security/BacktranslationProof.v index 8062900a84..6e3c5556c2 100644 --- a/security/BacktranslationProof.v +++ b/security/BacktranslationProof.v @@ -1675,16 +1675,44 @@ Section PROOF. 2:{ unfold unbundle. ss. traceEq. } left. assert (id = id_cur). { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } - subst id. exists id_cur. split. + subst id. 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_C in H. clarify. } + subst b. assert (f0 = f). + { rewrite FINDF_C_CUR in H0. clarify. } + subst f0. ss. 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. + admit. (*ez*) + * 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. TODO - - - 3:{ ii. rewrite CNT_CUR in H. inv H. ss. } From a1a4bdac0da8a20f6c88872da40e8cc0cc6a2bad Mon Sep 17 00:00:00 2001 From: ldj Date: Sat, 23 Sep 2023 21:44:17 +0900 Subject: [PATCH 161/174] proved bt sim --- security/BacktranslationProof.v | 2478 ++++++++++++++++++------------- 1 file changed, 1442 insertions(+), 1036 deletions(-) diff --git a/security/BacktranslationProof.v b/security/BacktranslationProof.v index 6e3c5556c2..aae7a6c1e4 100644 --- a/security/BacktranslationProof.v +++ b/security/BacktranslationProof.v @@ -516,1012 +516,1523 @@ Section PROOF. } 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. - (* WIP *) - 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_c pretr ttr cnts id cst1) - (MS: match_state ge_i ge_c k ttr cnts pars id ist1 cst1) + Lemma not_ptr_val_inject_eq + j v1 v2 + (VI: Val.inject j v1 v2) + (NPTR: not_ptr v1) : - exists cst2, (star step1 ge_c cst1 (unbundle ev) cst2) /\ - ((exists id', (wf_c_state 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)). + 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) (f : function), + Genv.find_symbol ge_c id = Some b -> + Genv.find_funct_ptr ge_c b = Some (Internal f) -> + exists cnt : ident, + cnts ! id = Some cnt /\ + wf_counter ge_c m_c (comp_of f) (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_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. - (* REMOVE *) - Set Nested Proofs Allowed. + assert (id = id_cur). + { unfold match_cur_fun in MS2. des. rewrite MS7 in IDCUR. clarify. } + subst id. + rename f_next into fi_next. - 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. + 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. + 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)). + { destruct MS2 as (MFUN0 & MFUN1). auto. } - (** Case 1: Cross Call *) - - 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. - 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)). - { destruct MS2 as (MFUN0 & MFUN1). auto. } + exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. } - exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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 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). + 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. } + + 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. } - 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. } - - 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). - 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. } - - 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_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. + 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. } - apply INJINCR. apply NALLOC. apply DELTA. apply PUB. - intros (m_c' & DELTA' & INJ'). exists m_c'. splits; auto. - rewrite CP_CUR. auto. + 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. } - 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. } + { 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. } - 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). + { 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. - 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 (ENV_NINJ: not_inj_blks (meminj_public 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. *) - (* unfold meminj_public. des_ifs. exfalso. simpl in Heq. *) - (* move MS1 after Heq0. destruct MS1 as (MM1 & MM2 & MM3). *) - (* erewrite match_symbs_meminj_public in MEMINJ_CNT. *) - (* 2:{ destruct MS0 as (MS0 & _). apply MS0. } *) - (* hexploit Mem.valid_block_inject_2. 2: eapply MEMINJ_CNT. *) - (* { unfold meminj_public. setoid_rewrite Heq. rewrite Heq0. eauto. } *) - (* eapply alloc_variables_one_fresh_block. eapply ENV_ALLOC. *) - (* { rewrite app_nil_r. eapply MP1. eauto. } *) - (* ss. eapply H0. *) - (* } *) - - assert (WFC_NEXT: wf_c_state 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. - admit. (*ez*) + 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) (f : function), + Genv.find_symbol ge_c id = Some b -> + Genv.find_funct_ptr ge_c b = Some (Internal f) -> + exists cnt : ident, + cnts ! id = Some cnt /\ + wf_counter ge_c m_c (comp_of f) (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_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. + + 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)). + { destruct MS2 as (MFUN0 & MFUN1). auto. } + + exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. + + 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). + 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. } + + 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_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_C in H. clarify. } + subst b0. assert (f0 = f). + { rewrite FINDF_C_CUR in H0. clarify. } + subst f0. 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 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. } - destruct (Pos.eq_dec id id_cur). - * subst id. clarify. ss. rewrite FIND_CNT_CUR in WFC6. 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. + 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. assert (fd_cur = AST.Internal f_i_cur). + { rewrite FINDFD in FINDF_I_CUR; clarify. } + subst fd_cur. eapply sem_cast_proj_rettype. ss. 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 FINDF_I_CUR. 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. + assert (fd_cur = AST.Internal f_i_cur). + { rewrite FINDFD in FINDF_I_CUR; clarify. } + subst fd_cur. ss. erewrite proj_rettype_to_type_rettype_of_type_eq. 2: eapply H0. + eapply match_senv_eventval_match. 2: eapply H0. destruct MS0 as (MS0 & _). auto. + } + 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) (f : function), + Genv.find_symbol ge_c id = Some b -> + Genv.find_funct_ptr ge_c b = Some (Internal f) -> + exists cnt : ident, + cnts ! id = Some cnt /\ + wf_counter ge_c m_c (comp_of f) (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_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. + + 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_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)). + { destruct MS2 as (MFUN0 & MFUN1). auto. } + + exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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). + + 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). + 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. } + + 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_C in H. clarify. } + subst b. assert (f0 = f). + { rewrite FINDF_C_CUR in H0. clarify. } + subst f0. ss. 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. - admit. (*ez*) - * 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. + 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. - - - 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). + 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. } - - 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. + { 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. + } } + } - 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. + (* 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. } - - econs 2. - { eapply step_call. ss. - { econs. assert (FSN_C: Senv.find_symbol ge_c id_next = Some next). + 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 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. + { eapply match_symbs_vals_public_eval_to_vargs; auto. + destruct MS0 as (MS0 & _). auto. + eapply extcall_unkowns_vals_public; eauto. } - { 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. } + { 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. } - traceEq. - (** Case 2: Cross Return *) - - 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. - - 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)). - { destruct MS2 as (MFUN0 & MFUN1). auto. } + 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_C in H. clarify. } + subst b. assert (f0 = f). + { rewrite FINDF_C_CUR in H0. clarify. } + subst f0. 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: 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. + } - exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. + - 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. } - 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. - - 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). - 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. } - - 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. + { 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. } - 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. + } + + 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) (f : function), + Genv.find_symbol ge_c id = Some b -> + Genv.find_funct_ptr ge_c b = Some (Internal f) -> + exists cnt : ident, + cnts ! id = Some cnt /\ + wf_counter ge_c m_c (comp_of f) (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_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. + + set (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr) as ttr in *. + 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)). + { destruct MS2 as (MFUN0 & MFUN1). auto. } + + exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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). + + 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). + 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. } + + 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. - 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. + (* 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. } } - 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_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). + 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 (b1 = cnt_cur_b). - { setoid_rewrite WFC5 in FIND_CNT_CUR. clarify. } - subst b1. assert (b0 = cur). + subst cnt. assert (b0 = cnt_cur_b). + { setoid_rewrite WFC6 in FIND_CNT_CUR. clarify. } + subst b0. assert (b = cur). { rewrite FIND_CUR_C in H. clarify. } - subst b0. assert (f0 = f). + subst b. assert (f0 = f). { rewrite FINDF_C_CUR in H0. clarify. } - subst f0. erewrite Mem.load_store_same. 2: eapply CNT_CUR_STORE. + subst f0. ss. 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. - admit. (*ez*) + 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. + 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 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. assert (fd_cur = AST.Internal f_i_cur). - { rewrite FINDFD in FINDF_I_CUR; clarify. } - subst fd_cur. eapply sem_cast_proj_rettype. ss. 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 FINDF_I_CUR. 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. - assert (fd_cur = AST.Internal f_i_cur). - { rewrite FINDFD in FINDF_I_CUR; clarify. } - subst fd_cur. ss. erewrite proj_rettype_to_type_rettype_of_type_eq. 2: eapply H0. - eapply match_senv_eventval_match. 2: eapply H0. destruct MS0 as (MS0 & _). auto. + 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. 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. + { 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. + } } - all: traceEq. traceEq. - - (** Case 3: Internal-External Call *) - - assert (id = id_cur). - { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } - subst id. rename id0 into id_next. - - 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_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)). - { destruct MS2 as (MFUN0 & MFUN1). auto. } + } - exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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). - - 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). - 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. } - - 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. + (* 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). - 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_C in H. clarify. } - subst b. assert (f0 = f). - { rewrite FINDF_C_CUR in H0. clarify. } - subst f0. ss. 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. - admit. (*ez*) - * 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. + 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. } - { 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. - } + 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. } - (* 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_C in H. clarify. } - subst b. assert (f0 = f). - { rewrite FINDF_C_CUR in H0. clarify. } - subst f0. 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: 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. - admit. (*ez*) - } - * 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. - } + 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_C in H. clarify. } + subst b. assert (f0 = f). + { rewrite FINDF_C_CUR in H0. clarify. } + subst f0. 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: 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. + - 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. } - { 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. + { 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_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_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 *) - - assert (id = id_cur). + - 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. - - set (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr) as ttr in *. + 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_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. } + { 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)). { destruct MS2 as (MFUN0 & MFUN1). auto. } - - exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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). - - 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). - 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. } - - 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. } + (* 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. } - econs 2. eapply step_skip_or_continue_loop1. left; auto. - econs 2. eapply step_skip_loop2. + ss. econs 2. + { eapply step_skip_or_continue_loop1. auto. } + econs 2. + { eapply step_skip_loop2. } econs 1. all: ss. - splits. 2:{ unfold unbundle. ss. traceEq. } + left. exists id_cur. clear STAR. split. - 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. + - 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 b0. 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 CNTS_CUR. clarify. } - subst cnt. assert (b0 = cnt_cur_b). - { setoid_rewrite WFC6 in FIND_CNT_CUR. clarify. } - subst b0. assert (b = cur). + { 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_C in H. clarify. } - subst b. assert (f0 = f). - { rewrite FINDF_C_CUR in H0. clarify. } + subst b0. assert (f0 = f). + { rewrite FIND_FUN_C in H0. clarify. } subst f0. ss. 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. - admit. (*ez*) + 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. + 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. + 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. } - } + { 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 4-2: observables unknown external calls *) + (* 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 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. + 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. } - clear CUR_SWITCH_STAR BOUND2. + 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). @@ -1535,27 +2046,29 @@ Section PROOF. 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. + + left. exists id_cur. clear STAR. split. { ss. splits; auto. - unfold wf_counters. split; auto. - move WFC0 after COMP_SAME. ii. specialize (WFC0 _ _ _ H H0). des. exists cnt. splits; 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 b0. splits; auto. - + move MCNTS after COMP_SAME. - eapply mem_valid_access_wunchanged_on. 2: eapply mem_unchanged_wunchanged; eapply UCH2. + 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 CNTS_CUR. clarify. } - subst cnt. assert (b0 = cnt_cur_b). - { setoid_rewrite WFC6 in FIND_CNT_CUR. clarify. } - subst b0. assert (b = cur). + { 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_C in H. clarify. } - subst b. assert (f0 = f). - { rewrite FINDF_C_CUR in H0. clarify. } + subst b0. assert (f0 = f). + { rewrite FIND_FUN_C in H0. clarify. } subst f0. 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. } @@ -1566,7 +2079,9 @@ Section PROOF. 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. - admit. (*ez*) + 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. } @@ -1576,28 +2091,28 @@ Section PROOF. 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. + { 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 COMP_SAME. move WFC1 after FREEENV. move WFC4 after FREEENV. + - 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. } - { 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. + { 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) b = None). - { move MCNTS after UCH7. specialize (MCNTS _ _ _ H H0 b ofs). - destruct (meminj_public ge_i b) eqn:CASES; ss. exfalso. + { 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. @@ -1614,116 +2129,8 @@ Section PROOF. } } - (** 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 (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. - } - - desH ECCASES; cycle 1. - { 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. assert (id = id_cur). - { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } - subst id. 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_C in H. clarify. } - subst b. assert (f0 = f). - { rewrite FINDF_C_CUR in H0. clarify. } - subst f0. ss. 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. - admit. (*ez*) - * 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. - - - TODO - - 3:{ ii. rewrite CNT_CUR in H. inv H. ss. } - - - - - - - - - Admitted. + 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) @@ -1762,7 +2169,6 @@ Section PROOF. Theorem ir_to_clight (ge_i: Asm.genv) (ge_c: Clight.genv) (WFGE: wf_ge ge_i) - (* (WFCG: wf_c_genv ge_c) *) ist cst ttr cnts pars k id (BOUND: Z.of_nat (Datatypes.length ttr) < Int64.modulus) From a4817d9f8b9ae83271485973fd36702709d7ec86 Mon Sep 17 00:00:00 2001 From: ldj Date: Sun, 24 Sep 2023 20:34:06 +0900 Subject: [PATCH 162/174] start init inv proof --- security/Backtranslation.v | 4867 ++++-------------------------- security/BacktranslationAux.v | 7 +- security/BacktranslationProof.v | 7 - security/BacktranslationProof2.v | 64 + 4 files changed, 676 insertions(+), 4269 deletions(-) create mode 100644 security/BacktranslationProof2.v diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 089d53962c..8363ee9cb5 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -11,4270 +11,615 @@ Require Import Ctypes Clight. - 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). - - Ltac take_step := econstructor; [econstructor; simpl_expr | | traceEq]; simpl. - - - Section SWITCH. - (** switch statement; used when converting a trace to a code **) - - Definition type_counter: type := Tlong Unsigned noattr. - Definition type_bool: type := Tint IBool Signed noattr. - - 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 cnt type_counter) - (Econst_long (Int64.repr n) type_counter) - type_bool) - (* if true *) - (Ssequence - (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; 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 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 (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 - (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 k e le m). - Proof. - intros; subst cp. unfold switch. destruct RANGE as [RA1 RA2]. - assert (G: forall n', - (Z.of_nat (length ss)) <= n' -> - n' <= 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 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. - - 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. - } - now apply G; lia. - 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))) -> +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). + +Ltac take_step := econstructor; [econstructor; simpl_expr | | traceEq]; simpl. + + +Section SWITCH. + (** switch statement; used when converting a trace to a code **) + + Definition type_counter: type := Tlong Unsigned noattr. + Definition type_bool: type := Tint IBool Signed noattr. + + 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 cnt type_counter) + (Econst_long (Int64.repr n) type_counter) + type_bool) + (* if true *) + (Ssequence + (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; 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 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. + 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 (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 + (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 k e le m). + Proof. + intros; subst cp. unfold switch. destruct RANGE as [RA1 RA2]. + assert (G: forall n', + (Z.of_nat (length ss)) <= n' -> + n' <= 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 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. + - 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. } - 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 **) - - Variable ge: Senv.t. - - Definition not_in_env (e: env) id := e ! id = None. - - (* Definition wf_env (e: env) := *) - (* forall id, if (Senv.public_symbol ge id) then not_in_env e id else True. *) - 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 + rewrite Int.eq_true; simpl. + eapply IH; lia. + } + now apply G; lia. + 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 **) + + Variable ge: Senv.t. + + Definition not_in_env (e: env) id := e ! id = None. + + 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). + + 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. + + 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. + + Definition list_eventval_to_list_expr (vs: list eventval): list expr := + List.map eventval_to_expr vs. + + 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_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') + 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. - - 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). - - 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. - - 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. - - Definition list_eventval_to_list_expr (vs: list eventval): list expr := - List.map eventval_to_expr vs. - - 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_env (e: env) (v: eventval): Prop := *) - (* match v with *) - (* | EVptr_global id _ => wf_env e id *) - (* | _ => True *) - (* end. *) - - Definition wf_eventval_pub (v: eventval): Prop := - match v with - | EVptr_global id _ => (Senv.public_symbol ge id = true) - | _ => True - end. - - (* Definition wf_eventval_ge (v: eventval): Prop := *) - (* match v with *) - (* | EVptr_global id _ => (exists b, Genv.find_symbol ge id = Some b) *) - (* | _ => True *) - (* end. *) - - (* Lemma wf_eventval_pub_ge *) - (* v *) - (* : *) - (* wf_eventval_pub v -> wf_eventval_ge v. *) - (* Proof. intros H. destruct v; simpl in *; auto. apply Genv.public_symbol_exists in H; auto. Qed. *) - - 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. - - (* Definition rettype_to_type: rettype -> type := *) - (* fun rt: rettype => *) - (* match rt with *) - (* | Tint8signed => Tint I8 Signed noattr *) - (* | Tint8unsigned => Tint I8 Unsigned noattr *) - (* | Tint16signed => Tint I16 Signed noattr *) - (* | Tint16unsigned => Tint I16 Unsigned noattr *) - (* | AST.Tvoid => Tvoid *) - (* | 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) - : - (* (rettype_of_type (rettype_to_type rt)) = rt. *) - 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. - - (* Lemma retttype_to_type_rettype_of_type_eq *) - (* ge evres rt res *) - (* (EVM: eventval_match ge evres (proj_rettype rt) res) *) - (* : *) - (* (rettype_of_type (rettype_to_type rt)) = 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 *) - (* Definition fun_data : Type := (typelist * type * calling_convention). *) - 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 := (list_typ_to_typelist sig.(sig_args), rettype_to_type sig.(sig_res), sig.(sig_cc)). *) - 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 _ tps tr cc => mkfundata tps tr cc end. *) - 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. - - (* (* Return case *) *) - (* Definition eventval_to_expr_return (v: eventval) (rt: rettype): expr := *) - (* let ty := rettype_to_type rt in *) - (* match v with *) - (* | EVint i => Econst_int i ty *) - (* | EVlong i => Econst_long i ty *) - (* | EVfloat f => Econst_float f ty *) - (* | EVsingle f => Econst_single f ty *) - (* | EVptr_global id ofs => ptr_of_id_ofs id ofs *) - (* end. *) - - End CODEAUX. - - - Section CONV. - - (* Context {F: Type}. *) - (* Context {V: Type}. *) - (* Variable ge: Genv.t F V. *) - - 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 - (* | Vint i => Some (Econst_int i (Tint I32 Signed noattr)) *) - (* | Vlong i => Some (Econst_long i (Tlong Signed noattr)) *) - (* | Vfloat f => Some (Econst_float f (Tfloat F64 noattr)) *) - (* | Vsingle f => Some (Econst_single f (Tfloat F32 noattr)) *) - (* | Vptr b ofs => let id := senv_invert_symbol_total ge b in Some (ptr_of_id_ofs id ofs) *) - | 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 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 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 targs := list_typ_to_list_type a_sg.(sig_args) 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 PTree.set id (Pos.add id m, gen_counter (comp_of gd)) pt) gds (@PTree.empty _). - - 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 := - fold_left (fun pt '(id, gd) => - match gen_params_one m gd with | Some ps => PTree.set id ps pt | None => pt end) gds (@PTree.empty _). - - 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 GENPROOFS. - - 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 next_id_lt - A (l: list (ident * A)) - id a - (IN: In (id, a) l) - : - Pos.lt id (next_id l). - Proof. - Admitted. - - 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. - Admitted. - - Lemma gen_params_lt - m agds - id ps - (GET: (gen_params m agds) ! id = Some ps) - p t - (IN: In (p, t) ps) - : - Pos.lt m p. - Proof. - Admitted. - - Lemma gen_params_wf - m agds - : - wf_params_of (gen_params m agds). - Proof. - Admitted. - - (* Lemma gen_params_wf_sig *) - (* m agds *) - (* : *) - (* wf_params_of_sig (gen_params m agds). *) - (* Proof. *) - (* Admitted. *) - - - 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. - - 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 GENPROOFS. - - - (* 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. *) - (* Admitted. *) - - (* 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 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: 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 (f: function), *) - (* (Genv.find_symbol ge id = Some b) -> (Genv.find_funct_ptr ge b = Some (Internal f)) -> *) - (* (exists cnt, (cnts ! id = Some cnt) /\ (wf_counter ge m (comp_of f) (length (get_id_tr tr id)) cnt))). *) - - (* 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)). *) - - (* 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: 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 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)) *) - (* (* (wf_env ge e /\ wf_env_unique_blocks e /\ wf_env_mem ge (comp_of f) e m_c) *) *) - (* | _ => False *) - (* end. *) - - (* 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. *) - - (* 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). *) - (* (* /\ (public_rev_perm m_i m_c). *) *) - - (* 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. *) - - - (* Definition meminj_same_block (j : meminj) := *) - (* forall b1 b2 del, j b1 = Some (b2, del) -> b1 = b2. *) - - - (* 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 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 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 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 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 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 star_cut_middle *) - (* stepk 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_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_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 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) *) - (* : *) - (* exists vargs2 vretv2, *) - (* (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))) 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. 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. *) - (* } *) - (* { 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. 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. eapply match_symbs_eventval_match; eauto. *) - (* - esplits. *) - (* + erewrite eventval_list_match_vals_to_eventvals. 2: eapply H. *) - (* eapply list_eventval_to_expr_val_eval; auto. eapply eventval_list_match_transl. *) - (* eapply match_senv_eventval_list_match; eauto. *) - (* + econs. eapply eventval_list_match_transl_val. 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. eapply eventval_match_sem_cast. *) - (* erewrite eventval_match_eventval_to_val. *) - (* eapply match_senv_eventval_match. eauto. eapply H. eapply match_senv_eventval_match. eauto. eapply H. *) - (* + econs. erewrite eventval_match_eventval_to_val. *) - (* eapply match_senv_eventval_match. eauto. eapply H. eapply match_senv_eventval_match. eauto. eapply H. *) - (* 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 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 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. *) - - (* 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 : 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) (f : function), *) - (* Genv.find_symbol ge_c id = Some b -> *) - (* Genv.find_funct_ptr ge_c b = Some (Internal f) -> *) - (* exists cnt : ident, *) - (* cnts ! id = Some cnt /\ *) - (* wf_counter ge_c m_c (comp_of f) (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 = [])) *) - (* : *) - (* exists cnt_cur cnt_cur_b, *) - (* (cnts ! id_cur = Some cnt_cur /\ Senv.find_symbol ge_c cnt_cur = Some cnt_cur_b) /\ *) - (* 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) *) - (* (unbundle (id_cur, Bundle_call tr id0 evargs (ef_sig ef) d)) *) - (* (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. *) - - (* 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_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)). *) - (* { destruct MS2 as (MFUN0 & MFUN1). auto. } *) - - (* exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. *) - - (* admit. (* ez *) } *) - - (* 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). *) - (* 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. } *) - - (* 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. *) - (* Admitted. *) - - - - (* (* WIP *) *) - (* 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_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_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. *) - (* (* REMOVE *) *) - (* Set Nested Proofs Allowed. *) - - (* 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 *) *) - (* - 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. *) - (* 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)). *) - (* { destruct MS2 as (MFUN0 & MFUN1). auto. } *) - - (* exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } *) - (* 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. } *) - - (* 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). *) - (* 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. } *) - - (* 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 (ENV_NINJ: not_inj_blks (meminj_public 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. *) *) - (* (* unfold meminj_public. des_ifs. exfalso. simpl in Heq. *) *) - (* (* move MS1 after Heq0. destruct MS1 as (MM1 & MM2 & MM3). *) *) - (* (* erewrite match_symbs_meminj_public in MEMINJ_CNT. *) *) - (* (* 2:{ destruct MS0 as (MS0 & _). apply MS0. } *) *) - (* (* hexploit Mem.valid_block_inject_2. 2: eapply MEMINJ_CNT. *) *) - (* (* { unfold meminj_public. setoid_rewrite Heq. rewrite Heq0. eauto. } *) *) - (* (* eapply alloc_variables_one_fresh_block. eapply ENV_ALLOC. *) *) - (* (* { rewrite app_nil_r. eapply MP1. eauto. } *) *) - (* (* ss. eapply H0. *) *) - (* (* } *) *) - - (* assert (WFC_NEXT: wf_c_state 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. *) - (* + destruct (Pos.eq_dec id id_cur). *) - (* * subst id. clarify. ss. rewrite FIND_CNT_CUR in WFC6. clarify. *) - (* erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. *) - (* 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. admit. (*ez*) } *) - (* erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. *) - (* 2:{ admit. (* same ez *) } *) - (* 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. *) - (* admit. (*ez*) *) - (* * ss. erewrite bind_parameters_mem_load. 2: eapply ENV_BIND. *) - (* 2:{ eapply alloc_variables_old_blocks. eapply ENV_ALLOC. 2: ii; ss. admit. (*ez*) } *) - (* erewrite alloc_variables_mem_load. 2: eapply ENV_ALLOC. *) - (* 2:{ admit. (* same ez *) } *) - (* 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. *) - - (* (** Case 2: Cross Return *) *) - (* - 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. *) - - (* 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)). *) - (* { destruct MS2 as (MFUN0 & MFUN1). auto. } *) - - (* exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } *) - (* 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. *) - - (* 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). *) - (* 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. } *) - - (* 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_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_C in H. clarify. } *) - (* subst b0. assert (f0 = f). *) - (* { rewrite FINDF_C_CUR in H0. clarify. } *) - (* subst f0. 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. *) - (* admit. (*ez*) *) - (* * 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. assert (fd_cur = AST.Internal f_i_cur). *) - (* { rewrite FINDFD in FINDF_I_CUR; clarify. } *) - (* subst fd_cur. eapply sem_cast_proj_rettype. ss. 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 FINDF_I_CUR. 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. *) - (* assert (fd_cur = AST.Internal f_i_cur). *) - (* { rewrite FINDFD in FINDF_I_CUR; clarify. } *) - (* subst fd_cur. ss. erewrite proj_rettype_to_type_rettype_of_type_eq. 2: eapply H0. *) - (* eapply match_senv_eventval_match. 2: eapply H0. destruct MS0 as (MS0 & _). auto. *) - (* } *) - (* 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. *) - - (* (** Case 3: Internal-External Call *) *) - (* - assert (id = id_cur). *) - (* { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } *) - (* subst id. rename id0 into id_next. *) - - (* 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_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)). *) - (* { destruct MS2 as (MFUN0 & MFUN1). auto. } *) - - (* exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } *) - (* destruct WF_CNT_CUR as (CNT_CUR_NPUB & cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). *) - - (* 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). *) - (* 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. } *) - - (* 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 (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_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_C in H. clarify. } *) - (* subst b. assert (f0 = f). *) - (* { rewrite FINDF_C_CUR in H0. clarify. } *) - (* subst f0. ss. 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. *) - (* admit. (*ez*) *) - (* * 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_C in H. clarify. } *) - (* subst b. assert (f0 = f). *) - (* { rewrite FINDF_C_CUR in H0. clarify. } *) - (* subst f0. 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: 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. *) - (* admit. (*ez*) *) - (* } *) - (* * 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. *) - (* } *) - (* } *) - (* } *) - - (* (** Case 4: Builtins *) *) - (* - assert (id = id_cur). *) - (* { unfold match_cur_fun in MS2. desH MS2. rewrite MS7 in IDCUR. clarify. } *) - (* subst id. *) - - (* set (pretr ++ (id_cur, Bundle_builtin tr ef (vals_to_eventvals ge_i vargs) d) :: btr) as ttr in *. *) - (* 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)). *) - (* { destruct MS2 as (MFUN0 & MFUN1). auto. } *) - - (* exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. 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. etransitivity. 2: eauto. unfold get_id_tr. admit. (* ez *) } *) - (* destruct WF_CNT_CUR as (CNT_CUR_NPUB & cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). *) - - (* 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). *) - (* 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. } *) - - (* 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_C in H. clarify. } *) - (* subst b. assert (f0 = f). *) - (* { rewrite FINDF_C_CUR in H0. clarify. } *) - (* subst f0. ss. 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. *) - (* admit. (*ez*) *) - (* * 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_C in H. clarify. } *) - (* subst b. assert (f0 = f). *) - (* { rewrite FINDF_C_CUR in H0. clarify. } *) - (* subst f0. 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: 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. *) - (* admit. (*ez*) *) - (* } *) - (* * 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. *) - (* } *) - (* } *) - (* } *) - - (* (** Case 5: Cross Call External 1 *) *) - (* - *) - - - (* TODO *) - - - - - (* Admitted. *) - - (* Lemma ir_to_clight_aux *) - (* (ge_i: Asm.genv) (ge_c: Clight.genv) *) - (* (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_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) *) - (* (WFCG: wf_c_genv ge_c) *) - (* ist cst *) - (* ttr cnts k id *) - (* (WFC: wf_c_state ge_c [] ttr cnts id cst) *) - (* (MS: match_state ge_i ge_c k ttr cnts 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. 4,5,6,7: eauto. all: eauto. econs 1. ss. econs 1. Qed. *) - - (* End PROOF. *) - -(* Genv.initmem_inject: forall [F V : Type] {CF : has_comp F} (p : AST.program F V) [m : mem], Genv.init_mem p = Some m -> Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m *) -(* Genv.alloc_globals_neutral: *) -(* forall [F V : Type] {CF : has_comp F} (ge : Genv.t F V) [thr : block], *) -(* (forall (id : ident) (b : block), Genv.find_symbol ge id = Some b -> Plt b thr) -> *) -(* forall (gl : list (ident * globdef F V)) (m m' : mem), Genv.alloc_globals ge m gl = Some m' -> Mem.inject_neutral thr m -> Ple (Mem.nextblock m') thr -> Mem.inject_neutral thr m' *) + Lemma proj_rettype_to_type_rettype_of_type_eq + ge evres rt res + (EVM: eventval_match ge evres (proj_rettype rt) res) + : + (* (rettype_of_type (rettype_to_type rt)) = rt. *) + 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 PTree.set id (Pos.add id m, gen_counter (comp_of gd)) pt) gds (@PTree.empty _). + + 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 := + fold_left (fun pt '(id, gd) => + match gen_params_one m gd with | Some ps => PTree.set id ps pt | None => pt end) gds (@PTree.empty _). + + 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. + + 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 index 993ec106af..87a8697399 100644 --- a/security/BacktranslationAux.v +++ b/security/BacktranslationAux.v @@ -383,7 +383,12 @@ Section GENV. : symbols_inject (meminj_public ge1) ge1 ge2. Proof. - Admitted. + 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. diff --git a/security/BacktranslationProof.v b/security/BacktranslationProof.v index aae7a6c1e4..acec7b4ace 100644 --- a/security/BacktranslationProof.v +++ b/security/BacktranslationProof.v @@ -57,7 +57,6 @@ Section INVS. (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)) - (* (wf_env ge e /\ wf_env_unique_blocks e /\ wf_env_mem ge (comp_of f) e m_c) *) | _ => False end. @@ -67,7 +66,6 @@ Section INVS. 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). - (* /\ (public_rev_perm m_i m_c). *) 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)) /\ @@ -2181,8 +2179,3 @@ Section PROOF. Proof. eapply ir_to_clight_aux. eauto. 4,5,6,7: eauto. all: eauto. econs 1. econs 1. Qed. End PROOF. -(* Genv.initmem_inject: forall [F V : Type] {CF : has_comp F} (p : AST.program F V) [m : mem], Genv.init_mem p = Some m -> Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m *) -(* Genv.alloc_globals_neutral: *) -(* forall [F V : Type] {CF : has_comp F} (ge : Genv.t F V) [thr : block], *) -(* (forall (id : ident) (b : block), Genv.find_symbol ge id = Some b -> Plt b thr) -> *) -(* forall (gl : list (ident * globdef F V)) (m m' : mem), Genv.alloc_globals ge m gl = Some m' -> Mem.inject_neutral thr m -> Ple (Mem.nextblock m') thr -> Mem.inject_neutral thr m' *) diff --git a/security/BacktranslationProof2.v b/security/BacktranslationProof2.v new file mode 100644 index 0000000000..4eb192fc9a --- /dev/null +++ b/security/BacktranslationProof2.v @@ -0,0 +1,64 @@ +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 BacktranslationProof. + + +Section GENPROOFS. + + Lemma next_id_lt + A (l: list (ident * A)) + id a + (IN: In (id, a) l) + : + Pos.lt id (next_id l). + Proof. + Admitted. + + 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. + Admitted. + + Lemma gen_params_lt + m agds + id ps + (GET: (gen_params m agds) ! id = Some ps) + p t + (IN: In (p, t) ps) + : + Pos.lt m p. + Proof. + Admitted. + + Lemma gen_params_wf + m agds + : + wf_params_of (gen_params m agds). + Proof. + Admitted. + + (* Lemma gen_params_wf_sig *) + (* m agds *) + (* : *) + (* wf_params_of_sig (gen_params m agds). *) + (* Proof. *) + (* Admitted. *) + +End GENPROOFS. +(* Genv.initmem_inject: forall [F V : Type] {CF : has_comp F} (p : AST.program F V) [m : mem], Genv.init_mem p = Some m -> Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m *) +(* Genv.alloc_globals_neutral: *) +(* forall [F V : Type] {CF : has_comp F} (ge : Genv.t F V) [thr : block], *) +(* (forall (id : ident) (b : block), Genv.find_symbol ge id = Some b -> Plt b thr) -> *) +(* forall (gl : list (ident * globdef F V)) (m m' : mem), Genv.alloc_globals ge m gl = Some m' -> Mem.inject_neutral thr m -> Ple (Mem.nextblock m') thr -> Mem.inject_neutral thr m' *) From f53e32c45c04c2c402583442a522b4c0e68ee611 Mon Sep 17 00:00:00 2001 From: ldj Date: Mon, 25 Sep 2023 18:18:57 +0900 Subject: [PATCH 163/174] start proof 2 --- security/BacktranslationProof2.v | 125 +++++++++++++++++++++++++++++++ 1 file changed, 125 insertions(+) diff --git a/security/BacktranslationProof2.v b/security/BacktranslationProof2.v index 4eb192fc9a..a1a1572277 100644 --- a/security/BacktranslationProof2.v +++ b/security/BacktranslationProof2.v @@ -9,6 +9,7 @@ Require Import riscV.Asm. Require Import BtBasics BtInfoAsm MemoryDelta MemoryWeak. Require Import Ctypes Clight. Require Import Backtranslation BacktranslationAux BacktranslationProof. +Require Import RSC. Section GENPROOFS. @@ -62,3 +63,127 @@ End GENPROOFS. (* forall [F V : Type] {CF : has_comp F} (ge : Genv.t F V) [thr : block], *) (* (forall (id : ident) (b : block), Genv.find_symbol ge id = Some b -> Plt b thr) -> *) (* forall (gl : list (ident * globdef F V)) (m m' : mem), Genv.alloc_globals ge m gl = Some m' -> Mem.inject_neutral thr m -> Ple (Mem.nextblock m') thr -> Mem.inject_neutral thr m' *) + + +Section 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. + + (* Lemma behaves_star_prefix *) + (* L beh *) + (* (s: Smallstep.state L) *) + (* (BEH: state_behaves L s beh) *) + (* tr *) + (* (PRE: behavior_prefix tr beh) *) + (* : *) + (* exists s', Star L s tr s'. *) + (* Proof. *) + + (* Admitted. *) + + Theorem asm_to_clight + (p: Asm.program) (ast: Asm.state) + (WFP: wf_program p) + (WFMAIN: wf_main p) + (WFMAINSIG: wf_main_sig p) + (WFINIT: exists (s : Asm.state), Asm.initial_state p s) + (* (WF: exists (s: Smallstep.state (semantics p)), Smallstep.initial_state (semantics p) s) *) + : + forall tr, asm_program_does_prefix p tr -> + exists btr, + clight_program_does_prefix (gen_program btr p) tr /\ + unbundle_trace btr = tr. + Proof. + i. 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. } + { assert (star (step_fix (comp_of_main p)) (Genv.globalenv p) s tr s'). + { admit. (* fix asm step *) } + eapply H. + } + { eapply MS_I. } + intros (btr & ist' & UTR & ISTAR). esplits. 2: eauto. + eapply semantics_has_initial_trace_cut_implies_prefix. econs 1; ss. + + TODO + + Lemma gen_program_exists_initial_state + (p: Asm.program) btr + (ist : ir_state) + (IR_INIT : ir_initial_state p ist) + : + + +(* state_behaves_exists: forall (L : Smallstep.semantics) (s : Smallstep.state L), exists beh : program_behavior, state_behaves L s beh *) +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: forall b f m0, + let ge := Genv.globalenv p in + Genv.init_mem p = Some m0 -> + Genv.find_symbol ge p.(prog_main) = Some b -> + Genv.find_funct_ptr ge b = Some f -> + type_of_fundef f = Tfunction Tnil type_int32s cc_default -> + initial_state p (Callstate f nil Kstop m0). + Definition wf_c_state (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 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_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. + +Variant ir_initial_state (p : Asm.program) : ir_state -> Prop := + ir_initial_state_intro : forall (cur : block) (m0 : mem), + let ge := Genv.globalenv p in + Genv.find_symbol ge (AST.prog_main p) = Some cur -> + (exists f : Asm.function, Genv.find_funct_ptr ge cur = Some (AST.Internal f)) -> + Genv.init_mem p = Some m0 -> ir_initial_state p (Some (cur, m0, [])). + 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_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'. + + + +| step_internal_function : forall (f : function) (vargs : list val) (k : cont) (m : mem) (e : env) (le : temp_env) (m1 : mem), + function_entry f vargs m e le m1 -> + step ge function_entry (Callstate (Internal f) vargs k m) E0 (State f (fn_body f) k e le m1) +Inductive function_entry1 (ge : genv) (f : function) (vargs : list val) (m : mem) (e : env) (le : temp_env) (m' : mem) : Prop := + function_entry1_intro : forall m1 : mem, + list_norepet (var_names (fn_params f) ++ var_names (fn_vars f)) -> + alloc_variables ge (comp_of f) empty_env m (fn_params f ++ fn_vars f) e m1 -> + bind_parameters ge (comp_of f) e m1 (fn_params f) vargs m' -> + le = create_undef_temps (fn_temps f) -> function_entry1 ge f vargs m e le m'. +Complements.clight_program_has_initial_trace = +fun (p : program) (t : trace) => forall beh : program_behavior, program_behaves (semantics1 p) beh -> behavior_prefix t beh + : program -> trace -> Prop + +End PROOFINIT. From b658f169c067509e3740b62fbd94fd9ed73f5cd6 Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 26 Sep 2023 16:02:10 +0900 Subject: [PATCH 164/174] WIP --- security/Backtranslation.v | 17 +- security/BacktranslationProof2.v | 310 +++++++++++++++++++++++++++++-- 2 files changed, 311 insertions(+), 16 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 8363ee9cb5..0f00171f68 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -506,7 +506,10 @@ Section GEN. (* Generate fresh counter ids with definitions for each global definitions *) Definition gen_counter_defs m (gds: list (ident * globdef Asm.fundef unit)): PTree.t (ident * globdef Clight.fundef type) := - fold_left (fun pt '(id, gd) => PTree.set id (Pos.add id m, gen_counter (comp_of gd)) pt) gds (@PTree.empty _). + let gds' := map (fun '(id, gd) => (id, (Pos.add id m, gen_counter (comp_of gd)))) gds in + PTree_Properties.of_list gds'. + (* Definition gen_counter_defs m (gds: list (ident * globdef Asm.fundef unit)): PTree.t (ident * globdef Clight.fundef type) := *) + (* fold_left (fun pt '(id, gd) => PTree.set id (Pos.add id m, gen_counter (comp_of gd)) pt) gds (@PTree.empty _). *) Definition params_of := PTree.t (list (ident * type)). @@ -526,8 +529,16 @@ Section GEN. (* 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 := - fold_left (fun pt '(id, gd) => - match gen_params_one m gd with | Some ps => PTree.set id ps pt | None => pt end) gds (@PTree.empty _). + 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_params (m: ident) (gds: list (ident * globdef Asm.fundef unit)): params_of := *) + (* fold_left (fun pt '(id, gd) => *) + (* match gen_params_one m gd with | Some ps => PTree.set id ps pt | None => pt end) gds (@PTree.empty _). *) + 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 diff --git a/security/BacktranslationProof2.v b/security/BacktranslationProof2.v index a1a1572277..017b5a1932 100644 --- a/security/BacktranslationProof2.v +++ b/security/BacktranslationProof2.v @@ -64,26 +64,293 @@ End GENPROOFS. (* (forall (id : ident) (b : block), Genv.find_symbol ge id = Some b -> Plt b thr) -> *) (* forall (gl : list (ident * globdef F V)) (m m' : mem), Genv.alloc_globals ge m gl = Some m' -> Mem.inject_neutral thr m -> Ple (Mem.nextblock m') thr -> Mem.inject_neutral thr m' *) +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_props + (gds: list (ident * globdef Asm.fundef unit)) + cnts x0 + (CNTS: cnts = gen_counter_defs x0 gds) + : + Forall (fun '(id, (cnt, gd_c)) => + (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_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)). + (* In (id, ((id + x0)%positive, gen_counter (comp_of gd))) (PTree.elements cnts). *) + 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. + + + +wf_counters = +fun (ge : genv) (m : mem) (tr : bundle_trace) (cnts : cnt_ids) => +(forall (id0 id1 : positive) (cnt : ident), + cnts ! id0 = Some cnt -> cnts ! id1 = Some cnt -> id0 = id1) /\ +(forall (id : ident) (b : block) (f : function), + Genv.find_symbol ge id = Some b -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + exists cnt : ident, + cnts ! id = Some cnt /\ + wf_counter ge m (comp_of f) (Datatypes.length (get_id_tr tr id)) cnt) + : genv -> mem -> bundle_trace -> cnt_ids -> Prop + +Forall_map: forall [A B : Type] (f : A -> B) (P : B -> Prop) (l : list A), Forall P (map f l) <-> Forall (fun x : A => P (f x)) l +Forall_image: + forall [A B : Type] (f : A -> B) (l : list B), + Forall (fun y : B => exists x : A, y = f x) l <-> (exists l' : list A, l = map f l') + + Lemma gen_prog_defs_props + (a_ge: Senv.t) tr (gds: list (ident * globdef Asm.fundef unit)) + (gen_gds: list (ident * globdef Clight.fundef type)) + cnts params + (GEN: gen_gds = (map (fun '(id, gd) => (id, gen_progdef a_ge (get_id_tr tr id) gd (cnts ! id) (params ! id))) gds) ++ cnt_defs) + : + Forall (fun '(id, gd_c) => + ((id < r_cnt) -> + 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))) /\ + (r_cnt <= id + + + + + + (* Lemma gen_program_genv *) + (* btr (p_a: Asm.program) (p_c: Clight.program) *) + (* (P_C: p_c = gen_program btr p_a) *) + (* : *) + + + + 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. + + +Genv.find_symbol_exists: + forall [F V : Type] (p : AST.program F V) (id : ident) (g : globdef F V), + In (id, g) (AST.prog_defs p) -> exists b : block, Genv.find_symbol (Genv.globalenv p) id = Some b +Genv.find_symbol_inversion: + forall [F V : Type] (p : AST.program F V) (x : ident) [b : block], + Genv.find_symbol (Genv.globalenv p) x = Some b -> In x (prog_defs_names p) + + +Genv.globalenv = +fun (F V : Type) (p : AST.program F V) => +Genv.add_globals (Genv.empty_genv F V (AST.prog_public p) (AST.prog_pol p)) (AST.prog_defs p) + : forall F V : Type, AST.program F V -> Genv.t F V + +End PROOFGENV. + Section PROOFINIT. + Lemma gen_counter_defs_alloc + x0 gds cnts + (CNTS: cnts = gen_counter_defs x0 gds) + (ge: genv) + : + 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. + + + let cnts := gen_counter_defs m0 gds in + let cnt_defs := map snd (PTree.elements cnts) in +wf_counter = +fun (ge : Senv.t) (m : mem) (cp : compartment) (n : nat) (cnt : ident) => +Senv.public_symbol ge cnt = false /\ +(exists b : block, + 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))) + : Senv.t -> mem -> compartment -> nat -> ident -> Prop + +gen_counter_defs = +fun (m : positive) (gds : list (ident * globdef Asm.fundef unit)) => +fold_left + (fun (pt : PTree.tree (positive * globdef fundef type)) '(id, gd) => PTree.set id ((id + m)%positive, gen_counter (comp_of gd)) pt) + gds (PTree.empty (positive * globdef fundef type)) + : positive -> list (ident * globdef Asm.fundef unit) -> PTree.t (ident * globdef fundef type) + +Genv.alloc_global_exists: + forall [F V : Type] {CF : has_comp F} (ge : Genv.t F V) (m : mem) (idg : ident * globdef F V), + (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) -> exists m' : mem, Genv.alloc_global ge m idg = Some m' + + +Genv.alloc_globals = +fun (F V : Type) (CF : has_comp F) (ge : Genv.t F V) => +fix alloc_globals (m : mem) (gl : list (ident * globdef F V)) {struct gl} : option mem := + match gl with + | [] => Some m + | g :: gl' => match Genv.alloc_global ge m g with + | Some m' => alloc_globals m' gl' + | None => None + end + end + : forall F V : Type, has_comp F -> Genv.t F V -> mem -> list (ident * globdef F V) -> option mem + +Genv.alloc_globals_app: + forall [F V : Type] {CF : has_comp F} (ge : Genv.t F V) (gl1 gl2 : list (ident * globdef F V)) (m : mem) [m1 : mem], + Genv.alloc_globals ge m gl1 = Some m1 -> Genv.alloc_globals ge m1 gl2 = Genv.alloc_globals ge m (gl1 ++ gl2) + +Genv.init_mem = +fun (F V : Type) (CF : has_comp F) (p : AST.program F V) => Genv.alloc_globals (Genv.globalenv p) Mem.empty (AST.prog_defs p) + : forall F V : Type, has_comp F -> AST.program F V -> option mem + +Genv.globals_initialized = +fun (F V : Type) (ge g : Genv.t F V) (m : mem) => +forall (b : block) (gd : globdef F V), +Genv.find_def g b = Some gd -> +match gd with +| Gfun _ => + Mem.perm m b 0 Cur Nonempty /\ + (forall (ofs : Z) (k : perm_kind) (p : permission), Mem.perm m b ofs k p -> ofs = 0 /\ p = Nonempty) +| Gvar v => + Mem.range_perm m b 0 (init_data_list_size (gvar_init v)) Cur (Genv.perm_globvar v) /\ + (forall (ofs : Z) (k : perm_kind) (p : permission), + Mem.perm m b ofs k p -> 0 <= ofs < init_data_list_size (gvar_init v) /\ perm_order (Genv.perm_globvar v) p) /\ + (gvar_volatile v = false -> Genv.load_store_init_data ge m b 0 (gvar_init v) (Some (gvar_comp v))) /\ + (gvar_volatile v = false -> + Mem.loadbytes m b 0 (init_data_list_size (gvar_init v)) (Some (gvar_comp v)) = + Some (Genv.bytes_of_init_data_list ge (gvar_init v))) +end + : forall F V : Type, Genv.t F V -> Genv.t F V -> mem -> Prop + Lemma c_exists_init_mem + btr (p: Asm.program) + m_a + (MEMA: Genv.init_mem p = Some m_a) + : + exists m_c, Genv.init_mem (gen_program btr p) = Some m_c. + + + + 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) + _. + + + + + +Variant ir_initial_state (p : Asm.program) : ir_state -> Prop := + ir_initial_state_intro : forall (cur : block) (m0 : mem), + let ge := Genv.globalenv p in + Genv.find_symbol ge (AST.prog_main p) = Some cur -> + (exists f : Asm.function, Genv.find_funct_ptr ge cur = Some (AST.Internal f)) -> + Genv.init_mem p = Some m0 -> ir_initial_state p (Some (cur, m0, [])). +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: forall b f m0, + let ge := Genv.globalenv p in + Genv.init_mem p = Some m0 -> + Genv.find_symbol ge p.(prog_main) = Some b -> + Genv.find_funct_ptr ge b = Some f -> + type_of_fundef f = Tfunction Tnil type_int32s cc_default -> + initial_state p (Callstate f nil Kstop m0). + Definition wf_c_state (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 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_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. + + + 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. - (* Lemma behaves_star_prefix *) - (* L beh *) - (* (s: Smallstep.state L) *) - (* (BEH: state_behaves L s beh) *) - (* tr *) - (* (PRE: behavior_prefix tr beh) *) - (* : *) - (* exists s', Star L s tr s'. *) - (* Proof. *) - - (* Admitted. *) - Theorem asm_to_clight (p: Asm.program) (ast: Asm.state) (WFP: wf_program p) @@ -112,7 +379,24 @@ Section PROOFINIT. } { eapply MS_I. } intros (btr & ist' & UTR & ISTAR). esplits. 2: eauto. - eapply semantics_has_initial_trace_cut_implies_prefix. econs 1; ss. + eapply semantics_has_initial_trace_cut_implies_prefix. + assert (INIT_C: exists cst, Clight.initial_state (gen_program btr p) cst). + { admit. } + des. hexploit ir_to_clight. + { eapply wf_program_wf_ge; eauto. } + 4: eapply ISTAR. + { admit. } + { admit. } + { admit. } + intros CSTAR. des. econs 1; ss. + { admit. } + hexploit state_behaves_exists. intros (beh2 & BEH2). + esplits. + { admit. } + { eapply BEH2. } + + Admitted. + Qed. TODO From 0b91f4a6daadcdb334d2ab9460d1fd9637a86fc4 Mon Sep 17 00:00:00 2001 From: ldj Date: Tue, 26 Sep 2023 20:46:29 +0900 Subject: [PATCH 165/174] WIP --- security/BacktranslationProof2.v | 402 +++++++++++++++++++++++++++++++ 1 file changed, 402 insertions(+) diff --git a/security/BacktranslationProof2.v b/security/BacktranslationProof2.v index 017b5a1932..7f2755bc75 100644 --- a/security/BacktranslationProof2.v +++ b/security/BacktranslationProof2.v @@ -64,6 +64,9 @@ End GENPROOFS. (* (forall (id : ident) (b : block), Genv.find_symbol ge id = Some b -> Plt b thr) -> *) (* forall (gl : list (ident * globdef F V)) (m m' : mem), Genv.alloc_globals ge m gl = Some m' -> Mem.inject_neutral thr m -> Ple (Mem.nextblock m') thr -> Mem.inject_neutral thr m' *) +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 @@ -128,6 +131,404 @@ Section PROOFGENV. { 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 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). *) + + + +(* list_in_map_inv: forall [A B : Type] (f : A -> B) (l : list A) (y : B), In y (map f l) -> exists x : A, y = f x /\ In x l *) + + +(* Genv.find_def_symbol: *) +(* forall [F V : Type] (p : AST.program F V) (id : positive) (g : globdef F V), *) +(* (prog_defmap p) ! id = Some g <-> *) +(* (exists b : block, Genv.find_symbol (Genv.globalenv p) id = Some b /\ Genv.find_def (Genv.globalenv p) b = Some g) *) + + +(* eapply Genv.find_symbol_find_def_inversion in FIND. des. *) +(* apply Genv.find_def_inversion in FIND. des. *) + +(* Genv.find_symbol_find_def_inversion: *) +(* forall [F V : Type] (p : AST.program F V) (x : ident) [b : block], *) +(* Genv.find_symbol (Genv.globalenv p) x = Some b -> exists g : globdef F V, Genv.find_def (Genv.globalenv p) b = Some g *) +(* Genv.find_def_inversion: *) +(* forall [F V : Type] (p : AST.program F V) (b : block) [g : globdef F V], *) +(* Genv.find_def (Genv.globalenv p) b = Some g -> exists id : ident, In (id, g) (AST.prog_defs p) *) + +(* Genv.find_symbol_exists: *) +(* forall [F V : Type] (p : AST.program F V) (id : ident) (g : globdef F V), *) +(* In (id, g) (AST.prog_defs p) -> exists b : block, Genv.find_symbol (Genv.globalenv p) id = Some b *) + +(* unfold Genv.globalenv, gen_program, gen_prog_defs in FIND; ss. *) +(* destruct ( *) + + +(* apply Genv.find_symbol_inversion in FIND_C. unfold prog_defs_names in FIND_C. apply list_in_map_inv in FIND_C. *) +(* des. destruct x as (idx & gd). ss. subst idx. unfold gen_prog_defs in FIND_C0. apply in_app_or in FIND_C0. des. *) +(* - left. *) + + (* Lemma genv_find_symbol_only_in_gen *) + (* (p_a: Asm.program) btr *) + (* id *) + (* (FIND_A: Genv.find_symbol (Genv.globalenv p_a) id = None) *) + (* b *) + (* (FIND_C: Genv.find_symbol (Genv.globalenv (gen_program btr p_a)) id = Some b) *) + (* : *) + (* exists cp, Genv.find_def (Genv.globalenv (gen_program btr p_a)) b = Some (gen_counter cp). *) + (* Proof. *) + + TODO + +match_find_def = +fun (ge_i : Asm.genv) (ge_c : genv) (cnts : cnt_ids) (pars : params_of) (tr : bundle_trace) => +forall (b : block) (gd_i : globdef Asm.fundef unit) (id : ident), +Genv.find_def ge_i b = Some gd_i -> +Senv.invert_symbol ge_i b = Some id -> +match cnts ! id with +| Some cnt => + match pars ! id with + | Some params => Genv.find_def ge_c b = Some (gen_globdef ge_i cnt params (get_id_tr tr id) gd_i) + | None => False + end +| None => False +end + : Asm.genv -> genv -> cnt_ids -> params_of -> bundle_trace -> Prop + + 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). + + TODO + + hexploit (genv_def_to_some_ident _ NR). eauto. eauto. + i. des. + +wf_ge_block_to_id: + forall (F V : Type) (ge : Genv.t F V), + wf_ge ge -> + forall (b : block) (gd : globdef F V), Genv.find_def ge b = Some gd -> exists id : ident, Genv.invert_symbol ge b = Some id + + destruct (Genv.find_symbol (Genv.globalenv (gen_program btr p_a)) + + hexploit genv_find_symbol_gen_cases. + +Genv.find_symbol_find_def_inversion: + forall [F V : Type] (p : AST.program F V) (x : ident) [b : block], + Genv.find_symbol (Genv.globalenv p) x = Some b -> exists g : globdef F V, Genv.find_def (Genv.globalenv p) b = Some g +Genv.find_var_info_iff: + forall [F V : Type] (ge : Genv.t F V) (b : block) (v : globvar V), + Genv.find_var_info ge b = Some v <-> Genv.find_def ge b = Some (Gvar v) +genv_def_to_some_ident: + forall {F V : Type} (p : AST.program F V), + list_norepet (prog_defs_names p) -> + forall ge : Genv.t F V, + ge = Genv.globalenv p -> + forall (b : block) (gd : globdef F V), + Genv.find_def ge b = Some gd -> + exists (id : ident) (b' : block), Genv.find_symbol ge id = Some b' /\ Genv.find_def ge b' = Some gd + + +Genv.block_is_volatile = +fun (F V : Type) (ge : Genv.t F V) (b : block) => +match Genv.find_var_info ge b with +| Some gv => gvar_volatile gv +| None => false +end + : forall F V : Type, Genv.t F V -> block -> bool + 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. + + +Record program (F V : Type) : Type := mkprogram + { prog_defs : list (ident * globdef F V); prog_public : list ident; prog_main : ident; prog_pol : Policy.t }. + + unfold gen_program. +ListDec.In_dec: forall [A : Type], (forall x y : A, {x = y} + {x <> y}) -> forall (a : A) (l : list A), {In a l} + {~ In a l} +SetoidList.InA_alt: + forall [A : Type] (eqA : A -> A -> Prop) (x : A) (l : list A), SetoidList.InA eqA x l <-> (exists y : A, eqA x y /\ In y l) +in_dec: forall [A : Type], (forall x y : A, {x = y} + {x <> y}) -> forall (a : A) (l : list A), {In a l} + {~ In a l} + +Genv.globalenv_public: forall [F V : Type] (p : AST.program F V), Genv.genv_public (Genv.globalenv p) = AST.prog_public p + wf_counters = @@ -354,6 +755,7 @@ Inductive initial_state (p: program): state -> Prop := Theorem asm_to_clight (p: Asm.program) (ast: Asm.state) (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) From 94a477c4065c8d17400ea9e8ddd879d5cd61cbb1 Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 27 Sep 2023 14:06:33 +0900 Subject: [PATCH 166/174] WIP --- security/BacktranslationProof2.v | 420 +++++++++++++++++-------------- 1 file changed, 233 insertions(+), 187 deletions(-) diff --git a/security/BacktranslationProof2.v b/security/BacktranslationProof2.v index 7f2755bc75..80d5d62fa0 100644 --- a/security/BacktranslationProof2.v +++ b/security/BacktranslationProof2.v @@ -67,6 +67,8 @@ 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 @@ -118,7 +120,6 @@ Section PROOFGENV. (IN: In (id, gd) gds) : cnts ! id = Some ((id + x0)%positive, gen_counter (comp_of gd)). - (* In (id, ((id + x0)%positive, gen_counter (comp_of gd))) (PTree.elements cnts). *) Proof. subst. unfold gen_counter_defs. apply PTree_Properties.of_list_norepet. { rewrite map_map. @@ -384,75 +385,193 @@ Section PROOFGENV. } 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). *) - - - -(* list_in_map_inv: forall [A B : Type] (f : A -> B) (l : list A) (y : B), In y (map f l) -> exists x : A, y = f x /\ In x l *) - - -(* Genv.find_def_symbol: *) -(* forall [F V : Type] (p : AST.program F V) (id : positive) (g : globdef F V), *) -(* (prog_defmap p) ! id = Some g <-> *) -(* (exists b : block, Genv.find_symbol (Genv.globalenv p) id = Some b /\ Genv.find_def (Genv.globalenv p) b = Some g) *) - - -(* eapply Genv.find_symbol_find_def_inversion in FIND. des. *) -(* apply Genv.find_def_inversion in FIND. des. *) - -(* Genv.find_symbol_find_def_inversion: *) -(* forall [F V : Type] (p : AST.program F V) (x : ident) [b : block], *) -(* Genv.find_symbol (Genv.globalenv p) x = Some b -> exists g : globdef F V, Genv.find_def (Genv.globalenv p) b = Some g *) -(* Genv.find_def_inversion: *) -(* forall [F V : Type] (p : AST.program F V) (b : block) [g : globdef F V], *) -(* Genv.find_def (Genv.globalenv p) b = Some g -> exists id : ident, In (id, g) (AST.prog_defs p) *) - -(* Genv.find_symbol_exists: *) -(* forall [F V : Type] (p : AST.program F V) (id : ident) (g : globdef F V), *) -(* In (id, g) (AST.prog_defs p) -> exists b : block, Genv.find_symbol (Genv.globalenv p) id = Some b *) - -(* unfold Genv.globalenv, gen_program, gen_prog_defs in FIND; ss. *) -(* destruct ( *) - - -(* apply Genv.find_symbol_inversion in FIND_C. unfold prog_defs_names in FIND_C. apply list_in_map_inv in FIND_C. *) -(* des. destruct x as (idx & gd). ss. subst idx. unfold gen_prog_defs in FIND_C0. apply in_app_or in FIND_C0. des. *) -(* - left. *) - - (* Lemma genv_find_symbol_only_in_gen *) - (* (p_a: Asm.program) btr *) - (* id *) - (* (FIND_A: Genv.find_symbol (Genv.globalenv p_a) id = None) *) - (* b *) - (* (FIND_C: Genv.find_symbol (Genv.globalenv (gen_program btr p_a)) id = Some b) *) - (* : *) - (* exists cp, Genv.find_def (Genv.globalenv (gen_program btr p_a)) b = Some (gen_counter cp). *) - (* Proof. *) - - TODO - -match_find_def = -fun (ge_i : Asm.genv) (ge_c : genv) (cnts : cnt_ids) (pars : params_of) (tr : bundle_trace) => -forall (b : block) (gd_i : globdef Asm.fundef unit) (id : ident), -Genv.find_def ge_i b = Some gd_i -> -Senv.invert_symbol ge_i b = Some id -> -match cnts ! id with -| Some cnt => - match pars ! id with - | Some params => Genv.find_def ge_c b = Some (gen_globdef ge_i cnt params (get_id_tr tr id) gd_i) - | None => False - end -| None => False -end - : Asm.genv -> genv -> cnt_ids -> params_of -> bundle_trace -> Prop + 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 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 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 @@ -469,128 +588,55 @@ end { 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. - TODO - - hexploit (genv_def_to_some_ident _ NR). eauto. eauto. - i. des. - -wf_ge_block_to_id: - forall (F V : Type) (ge : Genv.t F V), - wf_ge ge -> - forall (b : block) (gd : globdef F V), Genv.find_def ge b = Some gd -> exists id : ident, Genv.invert_symbol ge b = Some id - - destruct (Genv.find_symbol (Genv.globalenv (gen_program btr p_a)) - - hexploit genv_find_symbol_gen_cases. - -Genv.find_symbol_find_def_inversion: - forall [F V : Type] (p : AST.program F V) (x : ident) [b : block], - Genv.find_symbol (Genv.globalenv p) x = Some b -> exists g : globdef F V, Genv.find_def (Genv.globalenv p) b = Some g -Genv.find_var_info_iff: - forall [F V : Type] (ge : Genv.t F V) (b : block) (v : globvar V), - Genv.find_var_info ge b = Some v <-> Genv.find_def ge b = Some (Gvar v) -genv_def_to_some_ident: - forall {F V : Type} (p : AST.program F V), - list_norepet (prog_defs_names p) -> - forall ge : Genv.t F V, - ge = Genv.globalenv p -> - forall (b : block) (gd : globdef F V), - Genv.find_def ge b = Some gd -> - exists (id : ident) (b' : block), Genv.find_symbol ge id = Some b' /\ Genv.find_def ge b' = Some gd - - -Genv.block_is_volatile = -fun (F V : Type) (ge : Genv.t F V) (b : block) => -match Genv.find_var_info ge b with -| Some gv => gvar_volatile gv -| None => false -end - : forall F V : Type, Genv.t F V -> block -> bool - 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) + 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) : - (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)). + eq_policy ge_a ge_c. Proof. + subst. unfold eq_policy. ss. unfold Genv.globalenv. ss. + rewrite ! Genv.genv_pol_add_globals. ss. + Qed. - -Record program (F V : Type) : Type := mkprogram - { prog_defs : list (ident * globdef F V); prog_public : list ident; prog_main : ident; prog_pol : Policy.t }. - - unfold gen_program. -ListDec.In_dec: forall [A : Type], (forall x y : A, {x = y} + {x <> y}) -> forall (a : A) (l : list A), {In a l} + {~ In a l} -SetoidList.InA_alt: - forall [A : Type] (eqA : A -> A -> Prop) (x : A) (l : list A), SetoidList.InA eqA x l <-> (exists y : A, eqA x y /\ In y l) -in_dec: forall [A : Type], (forall x y : A, {x = y} + {x <> y}) -> forall (a : A) (l : list A), {In a l} + {~ In a l} - -Genv.globalenv_public: forall [F V : Type] (p : AST.program F V), Genv.genv_public (Genv.globalenv p) = AST.prog_public p - - - -wf_counters = -fun (ge : genv) (m : mem) (tr : bundle_trace) (cnts : cnt_ids) => -(forall (id0 id1 : positive) (cnt : ident), - cnts ! id0 = Some cnt -> cnts ! id1 = Some cnt -> id0 = id1) /\ -(forall (id : ident) (b : block) (f : function), - Genv.find_symbol ge id = Some b -> - Genv.find_funct_ptr ge b = Some (Internal f) -> - exists cnt : ident, - cnts ! id = Some cnt /\ - wf_counter ge m (comp_of f) (Datatypes.length (get_id_tr tr id)) cnt) - : genv -> mem -> bundle_trace -> cnt_ids -> Prop - -Forall_map: forall [A B : Type] (f : A -> B) (P : B -> Prop) (l : list A), Forall P (map f l) <-> Forall (fun x : A => P (f x)) l -Forall_image: - forall [A B : Type] (f : A -> B) (l : list B), - Forall (fun y : B => exists x : A, y = f x) l <-> (exists l' : list A, l = map f l') - - Lemma gen_prog_defs_props - (a_ge: Senv.t) tr (gds: list (ident * globdef Asm.fundef unit)) - (gen_gds: list (ident * globdef Clight.fundef type)) - cnts params - (GEN: gen_gds = (map (fun '(id, gd) => (id, gen_progdef a_ge (get_id_tr tr id) gd (cnts ! id) (params ! id))) gds) ++ cnt_defs) + 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)) : - Forall (fun '(id, gd_c) => - ((id < r_cnt) -> - 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))) /\ - (r_cnt <= id - - - - - - (* Lemma gen_program_genv *) - (* btr (p_a: Asm.program) (p_c: Clight.program) *) - (* (P_C: p_c = gen_program btr p_a) *) - (* : *) - - - - 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. - - -Genv.find_symbol_exists: - forall [F V : Type] (p : AST.program F V) (id : ident) (g : globdef F V), - In (id, g) (AST.prog_defs p) -> exists b : block, Genv.find_symbol (Genv.globalenv p) id = Some b -Genv.find_symbol_inversion: - forall [F V : Type] (p : AST.program F V) (x : ident) [b : block], - Genv.find_symbol (Genv.globalenv p) x = Some b -> In x (prog_defs_names p) - - -Genv.globalenv = -fun (F V : Type) (p : AST.program F V) => -Genv.add_globals (Genv.empty_genv F V (AST.prog_public p) (AST.prog_pol p)) (AST.prog_defs p) - : forall F V : Type, AST.program F V -> Genv.t F V + match_genv ge_a ge_c. + Proof. + unfold match_genv, match_symbs. splits. + eapply gen_program_symbs_public; eauto. + eapply gen_program_symbs_find; eauto. + eapply gen_program_symbs_volatile; eauto. + eapply gen_program_eq_policy; eauto. + Qed. End PROOFGENV. From fbc78e08ba1346f0b64b4fbd219a251b1b268c4c Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 27 Sep 2023 15:39:37 +0900 Subject: [PATCH 167/174] WIP --- security/BacktranslationProof2.v | 200 ++++++++++++++++++++++++------- 1 file changed, 158 insertions(+), 42 deletions(-) diff --git a/security/BacktranslationProof2.v b/security/BacktranslationProof2.v index 80d5d62fa0..d08bf6d976 100644 --- a/security/BacktranslationProof2.v +++ b/security/BacktranslationProof2.v @@ -657,24 +657,134 @@ Section PROOFINIT. (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. - - - let cnts := gen_counter_defs m0 gds in - let cnt_defs := map snd (PTree.elements cnts) in -wf_counter = -fun (ge : Senv.t) (m : mem) (cp : compartment) (n : nat) (cnt : ident) => -Senv.public_symbol ge cnt = false /\ -(exists b : block, - 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))) - : Senv.t -> mem -> compartment -> nat -> ident -> Prop + 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 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. } + + TODO -gen_counter_defs = -fun (m : positive) (gds : list (ident * globdef Asm.fundef unit)) => -fold_left - (fun (pt : PTree.tree (positive * globdef fundef type)) '(id, gd) => PTree.set id ((id + m)%positive, gen_counter (comp_of gd)) pt) - gds (PTree.empty (positive * globdef fundef type)) - : positive -> list (ident * globdef Asm.fundef unit) -> PTree.t (ident * globdef fundef type) Genv.alloc_global_exists: forall [F V : Type] {CF : has_comp F} (ge : Genv.t F V) (m : mem) (idg : ident * globdef F V), @@ -686,6 +796,29 @@ Genv.alloc_global_exists: (forall (i : ident) (o : ptrofs), In (Init_addrof i o) (gvar_init v) -> exists b : block, Genv.find_symbol ge i = Some b) end) -> exists m' : mem, Genv.alloc_global ge m idg = Some m' + Definition wf_c_state (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 m_c tr cnts /\ + ( (wf_c_nb ge m_c)) + | _ => False + end. +(forall (id : ident) (b : block) (f : function), + Genv.find_symbol ge id = Some b -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + exists cnt : ident, + cnts ! id = Some cnt /\ wf_counter ge m (comp_of f) (Datatypes.length (get_id_tr tr id)) cnt) + : genv -> mem -> bundle_trace -> cnt_ids -> Prop + 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. Genv.alloc_globals = fun (F V : Type) (CF : has_comp F) (ge : Genv.t F V) => @@ -725,33 +858,16 @@ match gd with Some (Genv.bytes_of_init_data_list ge (gvar_init v))) end : forall F V : Type, Genv.t F V -> Genv.t F V -> mem -> Prop - Lemma c_exists_init_mem - btr (p: Asm.program) - m_a - (MEMA: Genv.init_mem p = Some m_a) - : - exists m_c, Genv.init_mem (gen_program btr p) = Some m_c. - +wf_counter = +fun (ge : Senv.t) (m : mem) (cp : compartment) (n : nat) (cnt : ident) => +Senv.public_symbol ge cnt = false /\ +(exists b : block, + 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))) + : Senv.t -> mem -> compartment -> nat -> ident -> Prop - 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) - _. From a78f72d35214b011c6d00d91ad7592ae56df3ddb Mon Sep 17 00:00:00 2001 From: ldj Date: Wed, 27 Sep 2023 17:59:15 +0900 Subject: [PATCH 168/174] WIP --- security/BacktranslationProof2.v | 362 +++++++++++++------------------ 1 file changed, 149 insertions(+), 213 deletions(-) diff --git a/security/BacktranslationProof2.v b/security/BacktranslationProof2.v index d08bf6d976..2e750f3dbd 100644 --- a/security/BacktranslationProof2.v +++ b/security/BacktranslationProof2.v @@ -620,7 +620,7 @@ Section PROOFGENV. rewrite ! Genv.genv_pol_add_globals. ss. Qed. - Lemma gen_program_match_genv + Lemma gen_program_match_symbs p_a btr p_c ge_a ge_c (P_C: p_c = gen_program btr p_a) @@ -629,12 +629,26 @@ Section PROOFGENV. (WFPP: wf_program_public p_a) (NR: list_norepet (prog_defs_names p_a)) : - match_genv ge_a ge_c. + match_symbs ge_a ge_c. Proof. - unfold match_genv, match_symbs. splits. + 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. @@ -646,7 +660,7 @@ Section PROOFINIT. Lemma gen_counter_defs_alloc x0 gds cnts (CNTS: cnts = gen_counter_defs x0 gds) - (ge: genv) + F V (ge: Genv.t F V) : Forall (fun (idg: ident * (globdef fundef type)) => let (_, y) := idg in @@ -770,6 +784,26 @@ Section PROOFINIT. } 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 @@ -782,130 +816,51 @@ Section PROOFINIT. 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_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. + (* exists (Callstate (Internal (gen_function (Genv.globalenv p) i l (get_id_tr btr (AST.prog_main p)) f)) nil Kstop m_c). 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. - TODO - - -Genv.alloc_global_exists: - forall [F V : Type] {CF : has_comp F} (ge : Genv.t F V) (m : mem) (idg : ident * globdef F V), - (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) -> exists m' : mem, Genv.alloc_global ge m idg = Some m' - - Definition wf_c_state (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 m_c tr cnts /\ - ( (wf_c_nb ge m_c)) - | _ => False - end. -(forall (id : ident) (b : block) (f : function), - Genv.find_symbol ge id = Some b -> - Genv.find_funct_ptr ge b = Some (Internal f) -> - exists cnt : ident, - cnts ! id = Some cnt /\ wf_counter ge m (comp_of f) (Datatypes.length (get_id_tr tr id)) cnt) - : genv -> mem -> bundle_trace -> cnt_ids -> Prop - 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. -Genv.alloc_globals = -fun (F V : Type) (CF : has_comp F) (ge : Genv.t F V) => -fix alloc_globals (m : mem) (gl : list (ident * globdef F V)) {struct gl} : option mem := - match gl with - | [] => Some m - | g :: gl' => match Genv.alloc_global ge m g with - | Some m' => alloc_globals m' gl' - | None => None - end - end - : forall F V : Type, has_comp F -> Genv.t F V -> mem -> list (ident * globdef F V) -> option mem - -Genv.alloc_globals_app: - forall [F V : Type] {CF : has_comp F} (ge : Genv.t F V) (gl1 gl2 : list (ident * globdef F V)) (m : mem) [m1 : mem], - Genv.alloc_globals ge m gl1 = Some m1 -> Genv.alloc_globals ge m1 gl2 = Genv.alloc_globals ge m (gl1 ++ gl2) - -Genv.init_mem = -fun (F V : Type) (CF : has_comp F) (p : AST.program F V) => Genv.alloc_globals (Genv.globalenv p) Mem.empty (AST.prog_defs p) - : forall F V : Type, has_comp F -> AST.program F V -> option mem - -Genv.globals_initialized = -fun (F V : Type) (ge g : Genv.t F V) (m : mem) => -forall (b : block) (gd : globdef F V), -Genv.find_def g b = Some gd -> -match gd with -| Gfun _ => - Mem.perm m b 0 Cur Nonempty /\ - (forall (ofs : Z) (k : perm_kind) (p : permission), Mem.perm m b ofs k p -> ofs = 0 /\ p = Nonempty) -| Gvar v => - Mem.range_perm m b 0 (init_data_list_size (gvar_init v)) Cur (Genv.perm_globvar v) /\ - (forall (ofs : Z) (k : perm_kind) (p : permission), - Mem.perm m b ofs k p -> 0 <= ofs < init_data_list_size (gvar_init v) /\ perm_order (Genv.perm_globvar v) p) /\ - (gvar_volatile v = false -> Genv.load_store_init_data ge m b 0 (gvar_init v) (Some (gvar_comp v))) /\ - (gvar_volatile v = false -> - Mem.loadbytes m b 0 (init_data_list_size (gvar_init v)) (Some (gvar_comp v)) = - Some (Genv.bytes_of_init_data_list ge (gvar_init v))) -end - : forall F V : Type, Genv.t F V -> Genv.t F V -> mem -> Prop -wf_counter = -fun (ge : Senv.t) (m : mem) (cp : compartment) (n : nat) (cnt : ident) => -Senv.public_symbol ge cnt = false /\ -(exists b : block, - 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))) - : Senv.t -> mem -> compartment -> nat -> ident -> Prop - - - - - - - -Variant ir_initial_state (p : Asm.program) : ir_state -> Prop := - ir_initial_state_intro : forall (cur : block) (m0 : mem), - let ge := Genv.globalenv p in - Genv.find_symbol ge (AST.prog_main p) = Some cur -> - (exists f : Asm.function, Genv.find_funct_ptr ge cur = Some (AST.Internal f)) -> - Genv.init_mem p = Some m0 -> ir_initial_state p (Some (cur, m0, [])). -Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: forall b f m0, - let ge := Genv.globalenv p in - Genv.init_mem p = Some m0 -> - Genv.find_symbol ge p.(prog_main) = Some b -> - Genv.find_funct_ptr ge b = Some f -> - type_of_fundef f = Tfunction Tnil type_int32s cc_default -> - initial_state p (Callstate f nil Kstop m0). - Definition wf_c_state (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 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_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. @@ -914,6 +869,17 @@ Inductive initial_state (p: program): state -> Prop := Definition clight_program_does_prefix (p: Clight.program) (t: trace) := semantics_has_initial_trace_prefix (Clight.semantics1 p) t. + 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. + Theorem asm_to_clight (p: Asm.program) (ast: Asm.state) (WFP: wf_program p) @@ -921,7 +887,6 @@ Inductive initial_state (p: program): state -> Prop := (WFMAIN: wf_main p) (WFMAINSIG: wf_main_sig p) (WFINIT: exists (s : Asm.state), Asm.initial_state p s) - (* (WF: exists (s: Smallstep.state (semantics p)), Smallstep.initial_state (semantics p) s) *) : forall tr, asm_program_does_prefix p tr -> exists btr, @@ -944,94 +909,65 @@ Inductive initial_state (p: program): state -> Prop := { eapply MS_I. } intros (btr & ist' & UTR & ISTAR). esplits. 2: eauto. eapply semantics_has_initial_trace_cut_implies_prefix. - assert (INIT_C: exists cst, Clight.initial_state (gen_program btr p) cst). - { admit. } - des. hexploit ir_to_clight. + hexploit exists_initial_state; eauto. instantiate (1:=btr). + intros (f_cur & m_c & INIT_C & F_MAIN). + (* dup INIT_C. inv INIT_C0. econs 1; ss. eapply INIT_C. eapply star_state_behaves_cut. *) + 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. + (* clear - ISTAR INIT_C INIT_MEM_A IR_INIT WFP WFPP WFMAIN WFMAINSIG UTR. *) + 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. - { admit. } - { admit. } - { admit. } - intros CSTAR. des. econs 1; ss. - { admit. } - hexploit state_behaves_exists. intros (beh2 & BEH2). - esplits. - { admit. } - { eapply BEH2. } - - Admitted. + { admit. (* use ISTAR, UTR *) } + { 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. + - admit. + - 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. + - admit. + - unfold match_cur_fun. ss. splits; ss. eauto. + - eapply gen_program_match_find_def; eauto. + - econs; auto. + - admit. + - admit. + } + intros (cst' & STAR_C). hexploit state_behaves_exists. intros (beh2 & BEH2). + esplits; eauto. Qed. - TODO - - Lemma gen_program_exists_initial_state - (p: Asm.program) btr - (ist : ir_state) - (IR_INIT : ir_initial_state p ist) - : - - -(* state_behaves_exists: forall (L : Smallstep.semantics) (s : Smallstep.state L), exists beh : program_behavior, state_behaves L s beh *) -Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: forall b f m0, - let ge := Genv.globalenv p in - Genv.init_mem p = Some m0 -> - Genv.find_symbol ge p.(prog_main) = Some b -> - Genv.find_funct_ptr ge b = Some f -> - type_of_fundef f = Tfunction Tnil type_int32s cc_default -> - initial_state p (Callstate f nil Kstop m0). - Definition wf_c_state (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 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_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. - -Variant ir_initial_state (p : Asm.program) : ir_state -> Prop := - ir_initial_state_intro : forall (cur : block) (m0 : mem), - let ge := Genv.globalenv p in - Genv.find_symbol ge (AST.prog_main p) = Some cur -> - (exists f : Asm.function, Genv.find_funct_ptr ge cur = Some (AST.Internal f)) -> - Genv.init_mem p = Some m0 -> ir_initial_state p (Some (cur, m0, [])). - 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_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'. - - - -| step_internal_function : forall (f : function) (vargs : list val) (k : cont) (m : mem) (e : env) (le : temp_env) (m1 : mem), - function_entry f vargs m e le m1 -> - step ge function_entry (Callstate (Internal f) vargs k m) E0 (State f (fn_body f) k e le m1) -Inductive function_entry1 (ge : genv) (f : function) (vargs : list val) (m : mem) (e : env) (le : temp_env) (m' : mem) : Prop := - function_entry1_intro : forall m1 : mem, - list_norepet (var_names (fn_params f) ++ var_names (fn_vars f)) -> - alloc_variables ge (comp_of f) empty_env m (fn_params f ++ fn_vars f) e m1 -> - bind_parameters ge (comp_of f) e m1 (fn_params f) vargs m' -> - le = create_undef_temps (fn_temps f) -> function_entry1 ge f vargs m e le m'. -Complements.clight_program_has_initial_trace = -fun (p : program) (t : trace) => forall beh : program_behavior, program_behaves (semantics1 p) beh -> behavior_prefix t beh - : program -> trace -> Prop - End PROOFINIT. From 3b4822855612cf9fb503de51c41affd7514d8d8e Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 28 Sep 2023 15:20:18 +0900 Subject: [PATCH 169/174] WIP; modify inv --- security/BacktranslationProof.v | 24 ++++- security/BacktranslationProof2.v | 146 ++++++++++++++++++++++++++++++- 2 files changed, 164 insertions(+), 6 deletions(-) diff --git a/security/BacktranslationProof.v b/security/BacktranslationProof.v index acec7b4ace..dc681a72ff 100644 --- a/security/BacktranslationProof.v +++ b/security/BacktranslationProof.v @@ -22,11 +22,18 @@ Section INVS. (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: Clight.genv) (m: mem) (tr: bundle_trace) (cnts: cnt_ids) := + 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 (f: function), - (Genv.find_symbol ge id = Some b) -> (Genv.find_funct_ptr ge b = Some (Internal f)) -> - (exists cnt, (cnts ! id = Some cnt) /\ (wf_counter ge m (comp_of f) (length (get_id_tr tr id)) cnt))). + (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))). + (* Definition wf_counters (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 (f: function), *) + (* (Genv.find_symbol ge id = Some b) -> (Genv.find_funct_ptr ge b = Some (Internal f)) -> *) + (* (exists cnt, (cnts ! id = Some cnt) /\ (wf_counter ge m (comp_of f) (length (get_id_tr tr id)) cnt))). *) Inductive wf_c_cont (ge: Clight.genv) : mem -> cont -> Prop := | wf_c_cont_nil @@ -59,6 +66,15 @@ Section INVS. (wf_env ge e /\ (not_global_blks (ge) (blocks_of_env2 ge e)) /\ (wf_c_nb ge m_c)) | _ => False end. + (* Definition wf_c_state (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 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'). diff --git a/security/BacktranslationProof2.v b/security/BacktranslationProof2.v index 2e750f3dbd..93bbf8f4d7 100644 --- a/security/BacktranslationProof2.v +++ b/security/BacktranslationProof2.v @@ -820,6 +820,21 @@ Section PROOFINIT. 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 : @@ -860,8 +875,104 @@ Section PROOFINIT. - 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. + TODO + + Lemma in_def_ + +wf_counters = +fun (ge : genv) (m : mem) (tr : bundle_trace) (cnts : cnt_ids) => +(forall (id0 id1 : positive) (cnt : ident), + cnts ! id0 = Some cnt -> cnts ! id1 = Some cnt -> id0 = id1) /\ +(forall (id : ident) (b : block) (f : function), + Genv.find_symbol ge id = Some b -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + exists cnt : ident, + cnts ! id = Some cnt /\ wf_counter ge m (comp_of f) (Datatypes.length (get_id_tr tr id)) cnt) + : genv -> mem -> bundle_trace -> cnt_ids -> Prop + +wf_counter = +fun (ge : Senv.t) (m : mem) (cp : compartment) (n : nat) (cnt : ident) => +Senv.public_symbol ge cnt = false /\ +(exists b : block, + 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))) + : Senv.t -> mem -> compartment -> nat -> ident -> Prop +gen_counter_defs = +fun (m : positive) (gds : list (ident * globdef Asm.fundef unit)) => +let gds' := map (fun '(id, gd) => (id, ((id + m)%positive, gen_counter (comp_of gd)))) gds in +PTree_Properties.of_list gds' + : positive -> + list (ident * globdef Asm.fundef unit) -> PTree.t (ident * globdef fundef type) +Genv.find_symbol_inversion: + forall [F V : Type] (p : AST.program F V) (x : ident) [b : block], + Genv.find_symbol (Genv.globalenv p) x = Some b -> In x (prog_defs_names p) Definition asm_program_does_prefix (p: Asm.program) (t: trace) := @@ -959,12 +1070,43 @@ Section PROOFINIT. { 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. - - admit. + - 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. - admit. - - admit. + - 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. + apply Genv.find_symbol_inversion in H9. + + +(forall (id : ident) (b : block) (f : function), + Genv.find_symbol ge id = Some b -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + exists cnt : ident, + cnts ! id = Some cnt /\ wf_counter ge m (comp_of f) (Datatypes.length (get_id_tr tr id)) cnt) +wf_counter = +fun (ge : Senv.t) (m : mem) (cp : compartment) (n : nat) (cnt : ident) => +Senv.public_symbol ge cnt = false /\ +(exists b : block, + 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))) + : Senv.t -> mem -> compartment -> nat -> ident -> Prop + + admit. } intros (cst' & STAR_C). hexploit state_behaves_exists. intros (beh2 & BEH2). esplits; eauto. From 9158bcdd8751969cd3744810ecf5ec6e2e0d4069 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 28 Sep 2023 16:25:53 +0900 Subject: [PATCH 170/174] fixed inv --- security/BacktranslationProof.v | 265 +++++++++++++++++++------------- 1 file changed, 159 insertions(+), 106 deletions(-) diff --git a/security/BacktranslationProof.v b/security/BacktranslationProof.v index dc681a72ff..5972dad654 100644 --- a/security/BacktranslationProof.v +++ b/security/BacktranslationProof.v @@ -57,10 +57,10 @@ Section INVS. Definition wf_c_nb (ge: Clight.genv) (m: mem) := (Genv.genv_next ge <= Mem.nextblock m)%positive. - Definition wf_c_state (ge: Clight.genv) (tr ttr: bundle_trace) (cnts: cnt_ids) id (cst: Clight.state) := + 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 m_c tr cnts /\ + 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)) @@ -174,18 +174,18 @@ Section PROOF. Qed. Lemma star_cut_middle - stepk ge_c cst1 ev pretr ttr cnts ge_i pars ist2 + 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_c (pretr ++ [ev]) ttr cnts id' 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_c (pretr ++ [ev]) ttr cnts id' 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. @@ -254,12 +254,12 @@ Section PROOF. (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) (f : function), - Genv.find_symbol ge_c id = Some b -> - Genv.find_funct_ptr ge_c b = Some (Internal f) -> + (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 f) (Datatypes.length (get_id_tr pretr id)) 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) @@ -304,18 +304,22 @@ Section 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 Genv.invert_find_symbol in IDCUR. apply MSENV1 in IDCUR. auto. } + { 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. } + { auto. } - exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. intros (cnt_cur & CNTS_CUR & WF_CNT_CUR). + 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. @@ -326,12 +330,14 @@ Section PROOF. apply inj_le. apply list_length_filter_le. } - 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. + 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. } @@ -440,12 +446,12 @@ Section PROOF. (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) (f : function), - Genv.find_symbol ge_c id = Some b -> - Genv.find_funct_ptr ge_c b = Some (Internal f) -> + (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 f) (Datatypes.length (get_id_tr pretr id)) 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) @@ -568,12 +574,12 @@ Section PROOF. (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) (f : function), - Genv.find_symbol ge_c id = Some b -> - Genv.find_funct_ptr ge_c b = Some (Internal f) -> + (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 f) (Datatypes.length (get_id_tr pretr id)) 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) @@ -600,7 +606,7 @@ Section PROOF. 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_c (pretr ++ [(id_cur, Bundle_call tr id0 evargs (fn_sig f_next) d)]) + 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 @@ -620,12 +626,15 @@ Section PROOF. 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 Genv.invert_find_symbol in IDCUR. apply MSENV1 in IDCUR. auto. } + { 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. } + { auto. } - exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. intros (cnt_cur & CNTS_CUR & WF_CNT_CUR). + 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. } @@ -637,12 +646,14 @@ Section PROOF. 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. } - 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). 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. } @@ -705,7 +716,7 @@ Section PROOF. 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_c (pretr ++ [(id_cur, Bundle_call tr id_next evargs (fn_sig fi_next) d)]) ttr cnts id_next cst2). + 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. @@ -728,6 +739,12 @@ Section PROOF. } 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. @@ -904,12 +921,12 @@ Section PROOF. (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) (f : function), - Genv.find_symbol ge_c id = Some b -> - Genv.find_funct_ptr ge_c b = Some (Internal f) -> + (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 f) (Datatypes.length (get_id_tr pretr id)) 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) @@ -934,7 +951,7 @@ Section PROOF. 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_c (pretr ++ [(id_cur, Bundle_return tr evretv d)]) + 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 @@ -946,6 +963,9 @@ Section PROOF. 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. } @@ -957,9 +977,10 @@ Section PROOF. 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)). - { destruct MS2 as (MFUN0 & MFUN1). auto. } + { auto. } - exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. intros (cnt_cur & CNTS_CUR & WF_CNT_CUR). + 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)). @@ -976,12 +997,14 @@ Section PROOF. { inv IK. } clarify. - 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. + 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 FINDF_I_CUR. subst f. ss. } + { 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. @@ -1034,7 +1057,7 @@ Section PROOF. 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_c (pretr ++ [(id_cur, Bundle_return tr evretv d)]) ttr cnts id_next 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. @@ -1060,10 +1083,11 @@ Section PROOF. subst cnt. assert (b1 = cnt_cur_b). { setoid_rewrite WFC5 in FIND_CNT_CUR. clarify. } subst b1. assert (b0 = cur). - { rewrite FIND_CUR_C in H. clarify. } - subst b0. assert (f0 = f). - { rewrite FINDF_C_CUR in H0. clarify. } - subst f0. erewrite Mem.load_store_same. 2: eapply CNT_CUR_STORE. + { 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. @@ -1139,23 +1163,27 @@ Section PROOF. { 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. assert (fd_cur = AST.Internal f_i_cur). - { rewrite FINDFD in FINDF_I_CUR; clarify. } - subst fd_cur. eapply sem_cast_proj_rettype. ss. eapply H0. + - ss. + (* assert (fd_cur = AST.Internal f_i_cur). *) + (* { rewrite FINDFD in FINDF_I_CUR; clarify. } *) + (* subst fd_cur. *) + 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 FINDF_I_CUR. ss. } + { 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. - assert (fd_cur = AST.Internal f_i_cur). - { rewrite FINDFD in FINDF_I_CUR; clarify. } - subst fd_cur. ss. erewrite proj_rettype_to_type_rettype_of_type_eq. 2: eapply H0. - eapply match_senv_eventval_match. 2: eapply H0. destruct MS0 as (MS0 & _). auto. + (* assert (fd_cur = AST.Internal f_i_cur). *) + (* { rewrite FINDFD in FINDF_I_CUR; clarify. } *) + (* subst fd_cur. *) + (* ss. *) + 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. } @@ -1193,12 +1221,12 @@ Section PROOF. (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) (f : function), - Genv.find_symbol ge_c id = Some b -> - Genv.find_funct_ptr ge_c b = Some (Internal f) -> + (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 f) (Datatypes.length (get_id_tr pretr id)) 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) @@ -1225,7 +1253,7 @@ Section PROOF. 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_c + 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 @@ -1239,14 +1267,18 @@ Section 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 Genv.invert_find_symbol in IDCUR. apply MSENV1 in IDCUR. auto. } + { 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. } + { auto. } - exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. intros (cnt_cur & CNTS_CUR & WF_CNT_CUR). + 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). @@ -1255,13 +1287,16 @@ Section PROOF. } destruct WF_CNT_CUR as (CNT_CUR_NPUB & cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). - 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). 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. } @@ -1346,10 +1381,12 @@ Section PROOF. subst cnt. assert (b0 = cnt_cur_b). { setoid_rewrite WFC6 in FIND_CNT_CUR. clarify. } subst b0. assert (b = cur). - { rewrite FIND_CUR_C in H. clarify. } - subst b. assert (f0 = f). - { rewrite FINDF_C_CUR in H0. clarify. } - subst f0. ss. erewrite Mem.load_store_same. 2: eapply CNT_CUR_STORE. + { 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. @@ -1475,17 +1512,18 @@ Section PROOF. subst cnt. assert (b0 = cnt_cur_b). { setoid_rewrite WFC6 in FIND_CNT_CUR. clarify. } subst b0. assert (b = cur). - { rewrite FIND_CUR_C in H. clarify. } - subst b. assert (f0 = f). - { rewrite FINDF_C_CUR in H0. clarify. } - subst f0. ss. - eapply Mem.load_unchanged_on. eapply UCH2. + { 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: eapply CNT_CUR_STORE. + 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. @@ -1562,12 +1600,12 @@ Section PROOF. (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) (f : function), - Genv.find_symbol ge_c id = Some b -> - Genv.find_funct_ptr ge_c b = Some (Internal f) -> + (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 f) (Datatypes.length (get_id_tr pretr id)) 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) @@ -1589,7 +1627,7 @@ Section PROOF. 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_c + 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 /\ @@ -1601,14 +1639,18 @@ Section 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 Genv.invert_find_symbol in IDCUR. apply MSENV1 in IDCUR. auto. } + { 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. } + { auto. } - exploit WFC0. eapply FIND_CUR_C. eapply FIND_FUN_C. intros (cnt_cur & CNTS_CUR & WF_CNT_CUR). + 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). @@ -1617,16 +1659,18 @@ Section PROOF. } destruct WF_CNT_CUR as (CNT_CUR_NPUB & cnt_cur_b & FIND_CNT_CUR & CNT_CUR_MEM_VA & CNT_CUR_MEM_LOAD). - 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). 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. } + { 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). @@ -1682,10 +1726,12 @@ Section PROOF. subst cnt. assert (b0 = cnt_cur_b). { setoid_rewrite WFC6 in FIND_CNT_CUR. clarify. } subst b0. assert (b = cur). - { rewrite FIND_CUR_C in H. clarify. } - subst b. assert (f0 = f). - { rewrite FINDF_C_CUR in H0. clarify. } - subst f0. ss. erewrite Mem.load_store_same. 2: eapply CNT_CUR_STORE. + { 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. @@ -1793,17 +1839,18 @@ Section PROOF. subst cnt. assert (b0 = cnt_cur_b). { setoid_rewrite WFC6 in FIND_CNT_CUR. clarify. } subst b0. assert (b = cur). - { rewrite FIND_CUR_C in H. clarify. } - subst b. assert (f0 = f). - { rewrite FINDF_C_CUR in H0. clarify. } - subst f0. ss. - eapply Mem.load_unchanged_on. eapply UCH2. + { 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: eapply CNT_CUR_STORE. + 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. @@ -1868,11 +1915,11 @@ Section PROOF. (BOUND: Z.of_nat (Datatypes.length ttr) < Int64.modulus) (TOTAL: ttr = pretr ++ ev :: btr) cst1 k id - (WFC: wf_c_state ge_c pretr ttr cnts id cst1) + (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_c (pretr ++ [ev]) ttr cnts id' 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. @@ -1935,11 +1982,14 @@ Section PROOF. 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 Genv.invert_find_symbol in IDCUR. apply MSENV1 in IDCUR. auto. } + { 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 *) @@ -1977,10 +2027,12 @@ Section PROOF. subst cnt. assert (b1 = cnt_cur_b). { setoid_rewrite WFC6 in FIND_CNT. clarify. } subst b1. assert (b0 = cur). - { rewrite FIND_CUR_C in H. clarify. } - subst b0. assert (f0 = f). - { rewrite FIND_FUN_C in H0. clarify. } - subst f0. ss. erewrite Mem.load_store_same. 2: eapply CNT_CUR_STORE. + { 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. @@ -2080,17 +2132,18 @@ Section PROOF. subst cnt. assert (b1 = cnt_cur_b). { setoid_rewrite WFC6 in FIND_CNT. clarify. } subst b1. assert (b0 = cur). - { rewrite FIND_CUR_C in H. clarify. } - subst b0. assert (f0 = f). - { rewrite FIND_FUN_C in H0. clarify. } - subst f0. ss. - eapply Mem.load_unchanged_on. eapply UCH2. + { 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: eapply CNT_CUR_STORE. + 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. @@ -2156,7 +2209,7 @@ Section PROOF. (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_c pretr ttr cnts id cst) + (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) @@ -2186,7 +2239,7 @@ Section PROOF. ist cst ttr cnts pars k id (BOUND: Z.of_nat (Datatypes.length ttr) < Int64.modulus) - (WFC: wf_c_state ge_c [] ttr cnts id cst) + (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') From c03df0134d7bbc0817851b8362ca9cfa082ab7c5 Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 28 Sep 2023 19:11:45 +0900 Subject: [PATCH 171/174] WIP --- security/BacktranslationProof2.v | 298 +++++++++++++++++++++++++------ 1 file changed, 246 insertions(+), 52 deletions(-) diff --git a/security/BacktranslationProof2.v b/security/BacktranslationProof2.v index 93bbf8f4d7..3bcfdc3318 100644 --- a/security/BacktranslationProof2.v +++ b/security/BacktranslationProof2.v @@ -941,38 +941,173 @@ Section PROOFINIT. eapply genv_alloc_globals_flat_inj; eauto. Qed. - TODO - - Lemma in_def_ - -wf_counters = -fun (ge : genv) (m : mem) (tr : bundle_trace) (cnts : cnt_ids) => -(forall (id0 id1 : positive) (cnt : ident), - cnts ! id0 = Some cnt -> cnts ! id1 = Some cnt -> id0 = id1) /\ -(forall (id : ident) (b : block) (f : function), - Genv.find_symbol ge id = Some b -> - Genv.find_funct_ptr ge b = Some (Internal f) -> - exists cnt : ident, - cnts ! id = Some cnt /\ wf_counter ge m (comp_of f) (Datatypes.length (get_id_tr tr id)) cnt) - : genv -> mem -> bundle_trace -> cnt_ids -> Prop - -wf_counter = -fun (ge : Senv.t) (m : mem) (cp : compartment) (n : nat) (cnt : ident) => -Senv.public_symbol ge cnt = false /\ -(exists b : block, - 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))) - : Senv.t -> mem -> compartment -> nat -> ident -> Prop -gen_counter_defs = -fun (m : positive) (gds : list (ident * globdef Asm.fundef unit)) => -let gds' := map (fun '(id, gd) => (id, ((id + m)%positive, gen_counter (comp_of gd)))) gds in -PTree_Properties.of_list gds' - : positive -> - list (ident * globdef Asm.fundef unit) -> PTree.t (ident * globdef fundef type) -Genv.find_symbol_inversion: - forall [F V : Type] (p : AST.program F V) (x : ident) [b : block], - Genv.find_symbol (Genv.globalenv p) x = Some b -> In x (prog_defs_names p) + (* Lemma genv_add_globals_map_same_next *) + (* F1 V1 gds (ge_a0 ge_b1: Genv.t F V) *) + (* (GE: ge = Genv.add_globals *) + + (* ge_a := Genv.add_globals (Genv.empty_genv Asm.fundef unit (AST.prog_public p) (AST.prog_pol p)) *) + (* gds : Genv.t Asm.fundef unit *) + (* FIND : Genv.find_symbol *) + (* (Genv.add_globals *) + (* (Genv.empty_genv (Ctypes.fundef function) type (AST.prog_public p) (AST.prog_pol p)) *) + (* (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)) id = Some b *) + (* f : Forall (fun id0 : positive => id0 <> id) *) + (* (map fst (map snd (PTree.elements (gen_counter_defs (next_id gds) gds)))) *) + (* ============================ *) + (* (b < Genv.genv_next ge_a)%positive *) + + 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)) + (* (FIND: Genv.find_symbol (Genv.add_globals ge0 l) id = Some b) *) + 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 asm_program_does_prefix (p: Asm.program) (t: trace) := @@ -1056,7 +1191,32 @@ Genv.find_symbol_inversion: 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. - - admit. + - 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)))). + { admit. } + 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 @@ -1085,28 +1245,62 @@ Genv.find_symbol_inversion: - unfold match_cur_fun. ss. splits; ss. eauto. - eapply gen_program_match_find_def; eauto. - econs; auto. - - admit. + - 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. + TODO + + + eapply PTree_Properties.of_list_norepet; auto. +Genv.find_def_symbol: + forall [F V : Type] (p : AST.program F V) (id : positive) (g : globdef F V), + (prog_defmap p) ! id = Some g <-> + (exists b : block, + Genv.find_symbol (Genv.globalenv p) id = Some b /\ + Genv.find_def (Genv.globalenv p) b = Some g) + + +Genv.find_symbol_exists: + forall [F V : Type] (p : AST.program F V) (id : ident) (g : globdef F V), + In (id, g) (AST.prog_defs p) -> + exists b : block, Genv.find_symbol (Genv.globalenv p) id = Some b + +Genv.find_funct_ptr_inversion: + forall [F V : Type] (p : AST.program F V) (b : block) [f : F], + Genv.find_funct_ptr (Genv.globalenv p) b = Some f -> + exists id : ident, In (id, Gfun f) (AST.prog_defs p) + + forall [A : Type] (l : list (PTree.elt * A)) (k : PTree.elt) (v : A), + list_norepet (map fst l) -> In (k, v) l -> (PTree_Properties.of_list l) ! k = Some v + +in_gds_exists_params: + forall (gds : list (PTree.elt * globdef Asm.fundef unit)) (id : positive) + (gd_i : globdef Asm.fundef unit), + (PTree_Properties.of_list gds) ! id = Some gd_i -> + list_norepet (map fst gds) -> + forall x : ident, + exists ps : list (ident * type), + (gen_params x gds) ! id = Some ps /\ + Forall (fun '(id0, _) => (x <= id0)%positive) ps /\ + match gd_i with + | Gfun fd => map typ_to_type (sig_args (funsig fd)) = map snd ps + | Gvar _ => ps = [] + end + + admit. - 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. - apply Genv.find_symbol_inversion in H9. - - -(forall (id : ident) (b : block) (f : function), - Genv.find_symbol ge id = Some b -> - Genv.find_funct_ptr ge b = Some (Internal f) -> - exists cnt : ident, - cnts ! id = Some cnt /\ wf_counter ge m (comp_of f) (Datatypes.length (get_id_tr tr id)) cnt) -wf_counter = -fun (ge : Senv.t) (m : mem) (cp : compartment) (n : nat) (cnt : ident) => -Senv.public_symbol ge cnt = false /\ -(exists b : block, - 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))) - : Senv.t -> mem -> compartment -> nat -> ident -> Prop - - admit. + 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. From 28fb7f0aef4716556ac72d6e1524ee3fc6d0e92e Mon Sep 17 00:00:00 2001 From: ldj Date: Thu, 28 Sep 2023 22:32:22 +0900 Subject: [PATCH 172/174] done except for the axioms --- security/BacktranslationProof2.v | 479 +++++++++++++++++++++---------- 1 file changed, 324 insertions(+), 155 deletions(-) diff --git a/security/BacktranslationProof2.v b/security/BacktranslationProof2.v index 3bcfdc3318..3d8e846127 100644 --- a/security/BacktranslationProof2.v +++ b/security/BacktranslationProof2.v @@ -14,6 +14,23 @@ 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 @@ -30,39 +66,144 @@ Section GENPROOFS. : (Pos.lt m cnt). Proof. - Admitted. + 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 gen_params_lt + 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.lt m p. + Pos.le m p. Proof. - Admitted. + 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. - Admitted. - - (* Lemma gen_params_wf_sig *) - (* m agds *) - (* : *) - (* wf_params_of_sig (gen_params m agds). *) - (* Proof. *) - (* Admitted. *) + 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. -(* Genv.initmem_inject: forall [F V : Type] {CF : has_comp F} (p : AST.program F V) [m : mem], Genv.init_mem p = Some m -> Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m *) -(* Genv.alloc_globals_neutral: *) -(* forall [F V : Type] {CF : has_comp F} (ge : Genv.t F V) [thr : block], *) -(* (forall (id : ident) (b : block), Genv.find_symbol ge id = Some b -> Plt b thr) -> *) -(* forall (gl : list (ident * globdef F V)) (m m' : mem), Genv.alloc_globals ge m gl = Some m' -> Mem.inject_neutral thr m -> Ple (Mem.nextblock m') thr -> Mem.inject_neutral thr m' *) 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)). @@ -97,19 +238,19 @@ Section PROOFGENV. 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_props - (gds: list (ident * globdef Asm.fundef unit)) - cnts x0 - (CNTS: cnts = gen_counter_defs x0 gds) - : - Forall (fun '(id, (cnt, gd_c)) => - (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_props *) + (* (gds: list (ident * globdef Asm.fundef unit)) *) + (* cnts x0 *) + (* (CNTS: cnts = gen_counter_defs x0 gds) *) + (* : *) + (* Forall (fun '(id, (cnt, gd_c)) => *) + (* (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_inv (gds: list (ident * globdef Asm.fundef unit)) @@ -402,65 +543,65 @@ Section PROOFGENV. apply PTree_Properties.in_of_list in IN. apply list_in_map_inv in IN. des. des_ifs. 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 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 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 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 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 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 in_asm_in_gen p_a btr @@ -941,34 +1082,11 @@ Section PROOFINIT. eapply genv_alloc_globals_flat_inj; eauto. Qed. - (* Lemma genv_add_globals_map_same_next *) - (* F1 V1 gds (ge_a0 ge_b1: Genv.t F V) *) - (* (GE: ge = Genv.add_globals *) - - (* ge_a := Genv.add_globals (Genv.empty_genv Asm.fundef unit (AST.prog_public p) (AST.prog_pol p)) *) - (* gds : Genv.t Asm.fundef unit *) - (* FIND : Genv.find_symbol *) - (* (Genv.add_globals *) - (* (Genv.empty_genv (Ctypes.fundef function) type (AST.prog_public p) (AST.prog_pol p)) *) - (* (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)) id = Some b *) - (* f : Forall (fun id0 : positive => id0 <> id) *) - (* (map fst (map snd (PTree.elements (gen_counter_defs (next_id gds) gds)))) *) - (* ============================ *) - (* (b < Genv.genv_next ge_a)%positive *) - 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)) - (* (FIND: Genv.find_symbol (Genv.add_globals ge0 l) id = Some b) *) 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) @@ -1108,6 +1226,63 @@ Section PROOFINIT. } 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. + Definition asm_program_does_prefix (p: Asm.program) (t: trace) := @@ -1157,7 +1332,6 @@ Section PROOFINIT. 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). - (* dup INIT_C. inv INIT_C0. econs 1; ss. eapply INIT_C. eapply star_state_behaves_cut. *) econs 1; ss. eapply INIT_C. eapply star_state_behaves_cut. eexists. split. { econs 2. 2: econs 1. 2: traceEq. eapply step_internal_function. @@ -1166,7 +1340,6 @@ Section PROOFINIT. econs. econs. econs. } clear dependent s. clear dependent s'. clear dependent m0. clear beh' j. - (* clear - ISTAR INIT_C INIT_MEM_A IR_INIT WFP WFPP WFMAIN WFMAINSIG UTR. *) 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. @@ -1201,7 +1374,13 @@ Section PROOFINIT. 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)))). - { admit. } + { 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. } @@ -1252,47 +1431,37 @@ Section PROOFINIT. rewrite <- Genv.find_funct_ptr_iff. eauto. } i. des. rewrite H10 in H11. clarify. - + ii. - TODO - - - eapply PTree_Properties.of_list_norepet; auto. -Genv.find_def_symbol: - forall [F V : Type] (p : AST.program F V) (id : positive) (g : globdef F V), - (prog_defmap p) ! id = Some g <-> - (exists b : block, - Genv.find_symbol (Genv.globalenv p) id = Some b /\ - Genv.find_def (Genv.globalenv p) b = Some g) - - -Genv.find_symbol_exists: - forall [F V : Type] (p : AST.program F V) (id : ident) (g : globdef F V), - In (id, g) (AST.prog_defs p) -> - exists b : block, Genv.find_symbol (Genv.globalenv p) id = Some b - -Genv.find_funct_ptr_inversion: - forall [F V : Type] (p : AST.program F V) (b : block) [f : F], - Genv.find_funct_ptr (Genv.globalenv p) b = Some f -> - exists id : ident, In (id, Gfun f) (AST.prog_defs p) - - forall [A : Type] (l : list (PTree.elt * A)) (k : PTree.elt) (v : A), - list_norepet (map fst l) -> In (k, v) l -> (PTree_Properties.of_list l) ! k = Some v - -in_gds_exists_params: - forall (gds : list (PTree.elt * globdef Asm.fundef unit)) (id : positive) - (gd_i : globdef Asm.fundef unit), - (PTree_Properties.of_list gds) ! id = Some gd_i -> - list_norepet (map fst gds) -> - forall x : ident, - exists ps : list (ident * type), - (gen_params x gds) ! id = Some ps /\ - Forall (fun '(id0, _) => (x <= id0)%positive) ps /\ - match gd_i with - | Gfun fd => map typ_to_type (sig_args (funsig fd)) = map snd ps - | Gvar _ => ps = [] - end - - admit. + + 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. From 5c7ec23f75b8bc30b20534790e5823e1b90f10bb Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 29 Sep 2023 15:08:53 +0900 Subject: [PATCH 173/174] WIP --- Makefile | 2 +- security/BacktranslationProof2.v | 14 ++++-- security/BtInfoAsmBound.v | 82 ++++++++++++++++++++++++++++++++ 3 files changed, 93 insertions(+), 5 deletions(-) create mode 100644 security/BtInfoAsmBound.v diff --git a/Makefile b/Makefile index 31e5fa662a..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 Tactics.v MemoryWeak.v MemoryDelta.v BtBasics.v BtInfoAsm.v Backtranslation.v BacktranslationAux.v BacktranslationProof.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/security/BacktranslationProof2.v b/security/BacktranslationProof2.v index 3d8e846127..7832395704 100644 --- a/security/BacktranslationProof2.v +++ b/security/BacktranslationProof2.v @@ -1301,6 +1301,15 @@ Section PROOFINIT. des. exists s2, beh. split; auto. eapply star_trans. 2: eauto. eauto. ss. Qed. + 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. + Theorem asm_to_clight (p: Asm.program) (ast: Asm.state) (WFP: wf_program p) @@ -1323,10 +1332,7 @@ Section PROOFINIT. hexploit asm_to_ir. { eapply wf_program_wf_ge; eauto. } { eapply wf_asm_initial_state; eauto. } - { assert (star (step_fix (comp_of_main p)) (Genv.globalenv p) s tr s'). - { admit. (* fix asm step *) } - eapply H. - } + { eapply step_fix_fix. eauto. } { eapply MS_I. } intros (btr & ist' & UTR & ISTAR). esplits. 2: eauto. eapply semantics_has_initial_trace_cut_implies_prefix. 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. From 2190d5ba076e9cb4afc3bf94abda393079ccc59d Mon Sep 17 00:00:00 2001 From: ldj Date: Fri, 29 Sep 2023 15:43:05 +0900 Subject: [PATCH 174/174] cleanup --- security/Backtranslation.v | 6 -- security/BacktranslationProof.v | 21 ---- security/BacktranslationProof2.v | 166 +++++++++++++------------------ security/BtBasics.v | 114 --------------------- security/MemoryDelta.v | 27 ----- security/MemoryWeak.v | 28 ------ security/Tactics.v | 7 ++ 7 files changed, 75 insertions(+), 294 deletions(-) diff --git a/security/Backtranslation.v b/security/Backtranslation.v index 0f00171f68..b73e454228 100644 --- a/security/Backtranslation.v +++ b/security/Backtranslation.v @@ -304,7 +304,6 @@ Section CODEAUX. ge evres rt res (EVM: eventval_match ge evres (proj_rettype rt) res) : - (* (rettype_of_type (rettype_to_type rt)) = rt. *) proj_rettype (rettype_of_type (rettype_to_type rt)) = proj_rettype rt. Proof. inv EVM; destruct rt; simpl; auto. @@ -508,8 +507,6 @@ Section GEN. Definition gen_counter_defs m (gds: list (ident * globdef Asm.fundef unit)): PTree.t (ident * globdef Clight.fundef type) := let gds' := map (fun '(id, gd) => (id, (Pos.add id m, gen_counter (comp_of gd)))) gds in PTree_Properties.of_list gds'. - (* Definition gen_counter_defs m (gds: list (ident * globdef Asm.fundef unit)): PTree.t (ident * globdef Clight.fundef type) := *) - (* fold_left (fun pt '(id, gd) => PTree.set id (Pos.add id m, gen_counter (comp_of gd)) pt) gds (@PTree.empty _). *) Definition params_of := PTree.t (list (ident * type)). @@ -535,9 +532,6 @@ Section GEN. end) gds in PTree_Properties.of_list params'. - (* Definition gen_params (m: ident) (gds: list (ident * globdef Asm.fundef unit)): params_of := *) - (* fold_left (fun pt '(id, gd) => *) - (* match gen_params_one m gd with | Some ps => PTree.set id ps pt | None => pt end) gds (@PTree.empty _). *) 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 := diff --git a/security/BacktranslationProof.v b/security/BacktranslationProof.v index 5972dad654..267e88c557 100644 --- a/security/BacktranslationProof.v +++ b/security/BacktranslationProof.v @@ -29,11 +29,6 @@ Section INVS. (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))). - (* Definition wf_counters (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 (f: function), *) - (* (Genv.find_symbol ge id = Some b) -> (Genv.find_funct_ptr ge b = Some (Internal f)) -> *) - (* (exists cnt, (cnts ! id = Some cnt) /\ (wf_counter ge m (comp_of f) (length (get_id_tr tr id)) cnt))). *) Inductive wf_c_cont (ge: Clight.genv) : mem -> cont -> Prop := | wf_c_cont_nil @@ -66,15 +61,6 @@ Section INVS. (wf_env ge e /\ (not_global_blks (ge) (blocks_of_env2 ge e)) /\ (wf_c_nb ge m_c)) | _ => False end. - (* Definition wf_c_state (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 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'). @@ -1164,9 +1150,6 @@ Section PROOF. eapply step_return_1. - eapply eventval_to_expr_val_eval. auto. eapply H0. - ss. - (* assert (fd_cur = AST.Internal f_i_cur). *) - (* { rewrite FINDFD in FINDF_I_CUR; clarify. } *) - (* subst fd_cur. *) eapply sem_cast_proj_rettype. eapply H0. - eapply FREENEXT. } @@ -1178,10 +1161,6 @@ Section PROOF. 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. - (* assert (fd_cur = AST.Internal f_i_cur). *) - (* { rewrite FINDFD in FINDF_I_CUR; clarify. } *) - (* subst fd_cur. *) - (* ss. *) erewrite proj_rettype_to_type_rettype_of_type_eq. 2: eapply H0. eapply match_senv_eventval_match. 2: eapply H0. apply MS0. } diff --git a/security/BacktranslationProof2.v b/security/BacktranslationProof2.v index 7832395704..c6a7a13dbd 100644 --- a/security/BacktranslationProof2.v +++ b/security/BacktranslationProof2.v @@ -6,7 +6,7 @@ Require Import Split. Require Import Tactics. Require Import riscV.Asm. -Require Import BtBasics BtInfoAsm MemoryDelta MemoryWeak. +Require Import BtBasics BtInfoAsm BtInfoAsmBound MemoryDelta MemoryWeak. Require Import Ctypes Clight. Require Import Backtranslation BacktranslationAux BacktranslationProof. Require Import RSC. @@ -238,20 +238,6 @@ Section PROOFGENV. 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_props *) - (* (gds: list (ident * globdef Asm.fundef unit)) *) - (* cnts x0 *) - (* (CNTS: cnts = gen_counter_defs x0 gds) *) - (* : *) - (* Forall (fun '(id, (cnt, gd_c)) => *) - (* (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_inv (gds: list (ident * globdef Asm.fundef unit)) (NR: list_norepet (map fst gds)) @@ -543,66 +529,6 @@ Section PROOFGENV. apply PTree_Properties.in_of_list in IN. apply list_in_map_inv in IN. des. des_ifs. 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 in_asm_in_gen p_a btr p_c ge_a ge_c @@ -1010,7 +936,6 @@ Section PROOFINIT. } subst. do 2 eexists. split. - econs; eauto. - (* exists (Callstate (Internal (gen_function (Genv.globalenv p) i l (get_id_tr btr (AST.prog_main p)) f)) nil Kstop m_c). 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. @@ -1283,13 +1208,6 @@ Section PROOFINIT. rewrite (max_id0_base _ _ _ _ H0); auto. apply IHl1; auto. lia. Qed. - - - 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. - Lemma star_state_behaves_cut p s0 tr (CUT: exists s1, star step1 (globalenv p) s0 E0 s1 /\ @@ -1301,6 +1219,27 @@ Section PROOFINIT. 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' : @@ -1310,20 +1249,26 @@ Section PROOFINIT. (* TODO: FIXME *) Admitted. - Theorem asm_to_clight - (p: Asm.program) (ast: Asm.state) - (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, asm_program_does_prefix p tr -> - exists btr, - clight_program_does_prefix (gen_program btr p) tr /\ - unbundle_trace btr = tr. + 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. eapply semantics_has_initial_trace_prefix_implies_cut in H. + 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. } @@ -1365,7 +1310,7 @@ Section PROOFINIT. hexploit ir_to_clight. { eapply wf_program_wf_ge; eauto. } 4: eapply ISTAR. - { admit. (* use ISTAR, UTR *) } + { 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)))). @@ -1481,4 +1426,29 @@ Section PROOFINIT. esplits; eauto. Qed. -End PROOFINIT. +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 index d2c1e7c128..007275ddf4 100644 --- a/security/BtBasics.v +++ b/security/BtBasics.v @@ -4,24 +4,12 @@ Require Import AST Linking Smallstep Events Behaviors. Require Import Split. -(* Record syscall_properties (sem: extcall_sem) (sg: signature) : Prop := *) -(* mk_syscall_properties { *) -(* sc_args_match: *) -(* forall ge cp args m1 name evargs evres res m2, *) -(* sem ge cp args m1 (Event_syscall name evargs evres :: nil) res m2 -> *) -(* eventval_list_match ge evargs sg.(sig_args) args; *) -(* }. *) - Section GENV. Context {F: Type}. Context {V: Type}. - (* For NR, use below: *) - (* ::: mkpass Unusedglobproof.match_prog *) - (* match_prog_unique: *) - (* list_norepet (prog_defs_names tp) *) Lemma genv_def_to_some_ident (p: AST.program F V) (NR: list_norepet (prog_defs_names p)) @@ -118,13 +106,11 @@ Section MEM. forall f b ofs m1 m1' m2' (NOTMAP: meminj_notmap f b), Mem.perm m1' b ofs Cur Readable -> - (* Mem.perm m1' b ofs Cur Writable -> *) 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). - (* eapply Mem.perm_implies; eauto. constructor. *) Qed. Lemma loc_out_of_reach_unchanged_on_perm: @@ -139,12 +125,6 @@ Section MEM. eapply Mem.perm_valid_block; eauto. Qed. - (* Record unchanged_on (P : block -> Z -> Prop) (m_before m_after : mem) : Prop := mk_unchanged_on *) - (* { unchanged_on_nextblock : Ple (Mem.nextblock m_before) (Mem.nextblock m_after); *) - (* unchanged_on_perm : forall (b : block) (ofs : Z) (k : perm_kind) (p : permission), P b ofs -> Mem.valid_block m_before b -> Mem.perm m_before b ofs k p <-> Mem.perm m_after b ofs k p; *) - (* unchanged_on_contents : forall (b : block) (ofs : Z), P b ofs -> Mem.perm m_before b ofs Cur Readable -> ZMap.get ofs (Mem.mem_contents m_after) !! b = ZMap.get ofs (Mem.mem_contents m_before) !! b; *) - (* unchanged_on_own : forall (b : block) (cp : option compartment), Mem.valid_block m_before b -> Mem.can_access_block m_before b cp <-> Mem.can_access_block m_after b cp }. *) - Lemma inject_separated_notmap f f' m m' b (NM: meminj_notmap f b) @@ -161,29 +141,6 @@ Section MEM. specialize (SEP _ _ _ FB CONTRA). destruct SEP as [NV1 NV2]. congruence. Qed. -(* -forall b, b is the block of one of the counter -> - (forall b0 ofs, ~ (f b0 = Some (b, ofs))) - *) - - (** Events.v **) -(* (** External calls must commute with memory injections, *) - (* in the following sense. *) *) - (* ec_mem_inject: *) - (* forall ge1 ge2 c vargs m1 t vres m2 f m1' vargs', *) - (* symbols_inject f ge1 ge2 -> *) - (* sem ge1 c vargs m1 t vres m2 -> *) - (* Mem.inject f m1 m1' -> *) - (* Val.inject_list f vargs vargs' -> *) - (* exists f', exists vres', exists m2', *) - (* sem ge2 c vargs' m1' t vres' m2' *) - (* /\ Val.inject f' vres vres' *) - (* /\ Mem.inject f' m2 m2' *) - (* /\ Mem.unchanged_on (loc_unmapped f) m1 m2 *) - (* /\ Mem.unchanged_on (loc_out_of_reach f m1) m1' m2' *) - (* /\ inject_incr f f' *) - (* /\ inject_separated f f' m1 m1'; *) - End MEM. Section HASINIT. @@ -212,9 +169,6 @@ Section HASINIT. + red. exists (Goes_wrong E0). reflexivity. Qed. - (* semantics_determinate: forall p : program, determinate (Asm.semantics p) *) - (* sd_traces: forall [L : semantics], determinate L -> single_events L *) - Lemma state_behaves_app_inv_one L s1 beh t beh' (SE: single_events L) @@ -304,71 +258,3 @@ Section HASINIT. Qed. End HASINIT. - - -(* Section EXTCALL. *) - -(* Variant external_call_event_match_common *) -(* (ef: external_function) (ev: event) (ge: Senv.t) (cp: compartment) (m1: mem) *) -(* : val -> mem -> Prop := *) -(* | ext_match_vload *) -(* ch *) -(* (EF: ef = EF_vload ch) *) -(* id ofs evv *) -(* (EV: ev = Event_vload ch id ofs evv) *) -(* b res m2 *) -(* (SEM: volatile_load_sem ch ge cp (Vptr b ofs :: nil) m1 (ev :: nil) res m2) *) -(* : *) -(* external_call_event_match_common ef ev ge cp m1 res m2 *) -(* | ext_match_vstore *) -(* ch *) -(* (EF: ef = EF_vstore ch) *) -(* id ofs evv *) -(* (EV: ev = Event_vstore ch id ofs evv) *) -(* b argv m2 *) -(* (SEM: volatile_store_sem ch ge cp (Vptr b ofs :: argv :: nil) m1 (ev :: nil) Vundef m2) *) -(* : *) -(* external_call_event_match_common ef ev ge cp m1 Vundef m2 *) -(* | ext_match_annot *) -(* len text targs *) -(* (EF: ef = EF_annot len text targs) *) -(* evargs *) -(* (EV: ev = Event_annot text evargs) *) -(* vargs m2 *) -(* (SEM: extcall_annot_sem text targs ge cp vargs m1 (ev :: nil) Vundef m2) *) -(* : *) -(* external_call_event_match_common ef ev ge cp m1 Vundef m2 *) -(* | ext_match_external *) -(* name excp sg *) -(* (EF: ef = EF_external name excp sg) *) -(* evname evargs evres *) -(* (EV: ev = Event_syscall evname evargs evres) *) -(* vargs vres m2 *) -(* (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) *) -(* (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) *) -(* : *) -(* external_call_event_match_common ef ev ge cp m1 vres m2 *) -(* | ext_match_builtin *) -(* name sg *) -(* (EF: (ef = EF_builtin name sg) \/ (ef = EF_runtime name sg)) *) -(* evname evargs evres *) -(* (EV: ev = Event_syscall evname evargs evres) *) -(* (ISEXT: Builtins.lookup_builtin_function name sg = None) *) -(* vargs vres m2 *) -(* (SEM: external_functions_sem name sg ge cp vargs m1 (ev :: nil) vres m2) *) -(* (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) *) -(* : *) -(* external_call_event_match_common ef ev ge cp m1 vres m2 *) -(* | ext_match_inline_asm *) -(* txt sg strs *) -(* (EF: ef = EF_inline_asm txt sg strs) *) -(* evname evargs evres *) -(* (EV: ev = Event_syscall evname evargs evres) *) -(* vargs vres m2 *) -(* (SEM: inline_assembly_sem txt sg ge cp vargs m1 (ev :: nil) vres m2) *) -(* (ARGS: eventval_list_match ge evargs sg.(sig_args) vargs) *) -(* : *) -(* external_call_event_match_common ef ev ge cp m1 vres m2 *) -(* . *) - -(* End EXTCALL. *) diff --git a/security/MemoryDelta.v b/security/MemoryDelta.v index bcd6b4bbf2..89a4326111 100644 --- a/security/MemoryDelta.v +++ b/security/MemoryDelta.v @@ -538,33 +538,6 @@ Section PROPS. 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 mem_delta_inj_unchanged_on *) - (* j d m m' *) - (* (STRICT: meminj_strict j) *) - (* (APPD: mem_delta_apply_inj j d (Some m) = Some m') *) - (* : *) - (* Mem.unchanged_on (fun b ofs => (forall b0 ofsd, j b0 <> Some (b, ofsd)) \/ (exists b0 ofsd, j b0 = Some (b, ofsd) /\ mem_delta_unchanged d b0 (ofs - ofsd))) 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_inj_cons in APPD. destruct a. *) - (* - destruct d0 as [[[[ch b] ofs] v] cp]. destruct (j b) as [[b' ofs'] |] eqn:JB. *) - (* + exploit mem_delta_apply_inj_some. eauto. intros (mi & MEM). rewrite MEM in APPD. *) - (* specialize (IHd _ _ APPD). eapply Mem.unchanged_on_trans. *) - (* 2:{ eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H; eauto. destruct H1 as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. right. eauto. } *) - (* { simpl in *. eapply Mem.store_unchanged_on. eauto. intros. intros [CC | CC]. *) - (* - specialize (CC b ofs'). congruence. *) - (* - destruct CC as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. simpl in H2. destruct (Pos.eqb_spec b b1). *) - (* + subst b1. rewrite JB in JB1. inv JB1. specialize (H2 eq_refl). lia. *) - (* + specialize (STRICT _ _ _ _ _ JB JB1). subst b1. lia. *) - (* } *) - (* + specialize (IHd _ _ APPD). eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H; eauto. destruct H1 as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. right. eauto. *) - (* - specialize (IHd _ _ APPD). eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H; eauto. destruct H1 as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. right. eauto. *) - (* - specialize (IHd _ _ APPD). eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H; eauto. destruct H1 as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. right. eauto. *) - (* - specialize (IHd _ _ APPD). eapply Mem.unchanged_on_implies. eapply IHd. intros. simpl. inv H; eauto. destruct H1 as (b1 & ofsd & JB1 & UNCHG). inv UNCHG. right. eauto. *) - (* Qed. *) - - Lemma get_from_setN_same_upto_ofs ofs0 ofs l ofsd (OFS: ofs0 <= ofs < ofs0 + Z.of_nat (Datatypes.length l)) diff --git a/security/MemoryWeak.v b/security/MemoryWeak.v index 745949b785..6991b57ece 100644 --- a/security/MemoryWeak.v +++ b/security/MemoryWeak.v @@ -1462,19 +1462,6 @@ Section WINJ. right; red; intros. elim A. eapply perm_winj; eauto. Qed. - (* Lemma val_lessdef_winject_compose: *) - (* forall f v1 v2 v3, *) - (* Val.lessdef v1 v2 -> Val.inject f v2 v3 -> Val.inject f v1 v3. *) - (* Proof. *) - (* intros. inv H. auto. auto. *) - (* Qed. *) - - (* Lemma val_inject_lessdef_compose: *) - (* forall f v1 v2 v3, *) - (* Val.inject f v1 v2 -> Val.lessdef v2 v3 -> Val.inject f v1 v3. *) - (* Proof. *) - (* intros. inv H0. auto. inv H. auto. *) - (* Qed. *) (** Winjecting a memory into itself. *) @@ -1550,21 +1537,6 @@ Section WINJ. eapply owned_new_block; eauto. Qed. - (* Theorem store_winject_neutral: *) - (* forall chunk m b ofs v cp m' thr, *) - (* store chunk m b ofs v cp = Some m' -> *) - (* winject_neutral thr m -> *) - (* Plt b thr -> *) - (* Val.inject (flat_winj thr) v v -> *) - (* winject_neutral thr m'. *) - (* Proof. *) - (* intros; red. *) - (* exploit store_mapped_winj. eauto. eauto. apply flat_winj_no_overlap. *) - (* unfold flat_winj. apply pred_dec_true; auto. eauto. *) - (* replace (ofs + 0) with ofs by lia. *) - (* intros [m'' [A B]]. congruence. *) - (* Qed. *) - Theorem drop_winject_neutral: forall m b lo hi p cp m' thr, drop_perm m b lo hi p cp = Some m' -> diff --git a/security/Tactics.v b/security/Tactics.v index 2a2dfa9d6d..bd110a077a 100644 --- a/security/Tactics.v +++ b/security/Tactics.v @@ -5,6 +5,13 @@ (* *) (* *********************************************************************) +(* *********************************************************************) +(* *) +(* 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. *)